For the life of me I cannot figure this out. I have a summary spreadsheet that is compiled based on multiple other sheets within the same workbook. On the main sheet I find the last row and need to insert row with text but cannot. Getting stuck. I'm using an array as these fields will never change. But only the first value of the array is displaying and not the rest.
Here's my code:
sub Headers()
Dim last_row As Long
Dim Header() As Variant
Header = VBA.Array("koko", "momo", "dodo", "gogo")
last_row = Cells(Rows.Count, "B").End(xlUp).Row + 1
ActiveSheet.Cells(last_row, "A").Value = Header
End Sub
enter image description here
You have to resize the target range to get the full array contents
ActiveSheet.Cells(last_row, "A").Resize(1, UBound(Header) + 1).Value = Header
:-)
To put the array in several columns within one row simply resize the target. Remember that arrays are zero-based by default.
ActiveSheet.Cells(last_row, "A").Resize(1, Ubound(header)+1).Value = Header
To put the array in several rows within one column resize the target and transpose the array.
ActiveSheet.Cells(last_row, "A").Resize(Ubound(header)+1, 1).Value = application.transpose(Header)
To put the array into a single cell, Join the array.
ActiveSheet.Cells(last_row, "A").Value = Join(Header, ", ")
Related
I'm currently trying to use .Find to search for an array of items starting with "K". If there is a match then proceed to filter and delete the item. However, I'm not sure if .Find is able to incorporate the array into its condition. I've considered using For each and If, but the code would be considerably long. Anyone can help or give suggestion for a different method?
Dim ckFOH As Range
Dim Krange As Variant
Krange = Sheets("Master List").Range("G17:G" & Range("G17").End(xlDown).Row)
With Sheets("FOH")
Set ckFOH = .Columns("Q").Find(What:=Krange, LookIn:=xlValues)
If Not ckFOH Is Nothing Then
.Rows("5").AutoFilter Field:=17, Criteria1:="=K*"
.Range("A6:K" & Range("A6").End(xlDown).Row).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
End With
Find() method of Range object accepts any data type for its "What" parameter, but if you provide a Range (as per your code) or even a 1D array, it's only its first element being actually searched for
moreover from your description I believe that you want to delete all sheet "FOH" rows that have any of actual "K" values found in "Master List" column Q
so you may want to use AutoFilter() and directly filter column Q on all those values providing an array as Criteria1 parameter and activating its xlFilterValues Operator option
as per following code (further explanations in comments):
Option Explicit
Sub main()
Dim Krange As Variant
With Sheets("Master List") 'reference wanted sheet
Krange = Application.Transpose(.Range("G17", .Range("G17").End(xlDown)).Value) ' store referenced sheet column G values from row 17 down to last consecutive not empty cell - explicitly qualify ALL range references to referenced worksheet
End With
With Sheets("FOH") 'reference wanted sheet
With .Range("Q5", .Cells(.Rows.Count, "Q").End(xlUp)) 'reference its column Q range from row 5 (header) to last not empty row
.AutoFilter field:=1, Criteria1:=Krange, Operator:=xlFilterValues ' filtere referenec range on all 'Krange' array values
If CBool(Application.Subtotal(103, .Cells)) > 1 Then .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete ' if any filtered cells other then header, thene delete their entire rows
End With
.AutoFilterMode = False
End With
End Sub
I'm trying to make something that
loops through a range (header range) of values and collects them into an array or whatever
make a dictionary of arrays with keys that are the values in the range
loop through worksheets looking for those keys
for each key it finds,
a. make an array of the values below
b. pad all the arrays so their the same length
c. concatenate it to the array stored in the dictionary with the same key
copy the concatenated values back to the cells below the header range
I did 1,2,4 and 5. I skipped 3, because that's easy and I'll do it later. But 4 is tricky because I can't get a handle on how the dictionary and arrays work. I tried to make a dictionary of arrays, but they're making copies instead of references and sometimes the copies are empty. I don't know.
In javascript, it would just be:
make a dict = {}
loop through the values and do dict[value] = []
then dict[value].concatenate(newestarray)
Then flip the dict back in to an array with a for(var k in dict){} which in google sheets you would have to transpose. Annoying, but not terrible.
Then in the end, some function to put it back into the worksheet, which in google sheets would be trivial.
Here's my code for the 4 part:
With rws
For Each Key In headerdict 'loop through the keys in the dict
Set rrng = .Cells.Find(key, , _ 'find the key in the sheet
Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, _
Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
If rrng Is Not Empty Then
'find last cell in column of data
Set rdrng = .Cells(rws.Rows.Count, rrng.Column).End(xlUp)
'get range for column of data
Set rrng = .Range(.Cells(rrng.Row + 1, rrng.Column), _
.Cells(rdrng.Row, rdrng.Column))
rArray = rrng.Value 'make an array
zMax = Max(UBound(rArray, 2), zMax) 'set max list length
fakedict(Key) = rArray 'place array in fake dict for later smoothing
End If
Next
End With
For Each Key In fakedict 'now smooth the array
If fakedict(Key) Is Not Nothing Then
nArray = fakedict(Key)
ReDim Preserve nArray(1 To zMax, 1 To 1) 'resize the array
Else
ReDim nArray(1 To zMax, 1 To 1) 'or make one from nothing
End If
fakedict(Key) = nArray 'add to fake dict
Next
Then later I can combine into the real dict. So my question is how do I resize the array? I don't think redim preserve is the best way. Others have mangled with collections, but I have too much pandas and python thinking. I'm used to deal with vectors, not munge elements. Any ideas?
I was not sure if you needed to use a dictionary of arrays to achieve this; if I was doing it I would just copy blocks of cells between sheets directly.
First bit - identify where the headers are:
Option Explicit
' Get the range that includes the headers
' Assume the headers are in sheet "DB" in row 1
Private Function GetHeaders() As Range
Dim r As Range
Set r = [DB!A1]
Set GetHeaders = Range(r, r.End(xlToRight))
End Function
Second, identify the sheets to scan (I assumed they're in the same workbook)
' Get all sheets in this workbook that aren't the target DB sheet
Private Function GetSheets() As Collection
Dim sheet As Worksheet
Dim col As New Collection
For Each sheet In ThisWorkbook.Worksheets
If sheet.Name <> "DB" Then col.Add sheet
Next sheet
Set GetSheets = col
End Function
Now, scan through and copy cells
' Main function, loop through all headers in all sheets
' and copy data
Sub CollectData()
Dim sheets As Collection, sheet As Worksheet
Dim hdrs As Range, hdr As Range
Dim found As Range
' This is the row we are writing into on DB
Dim currentrow As Integer
' This is the maximum number of entries under a header on this sheet, used for padding
Dim maxcount As Integer
Set sheets = GetSheets
Set hdrs = GetHeaders
currentrow = 1
For Each sheet In sheets
maxcount = 0
For Each hdr In hdrs.Cells
' Assume each header appears only once in each sheet
Set found = sheet.Cells.Find(hdr.Value)
If Not found Is Nothing Then
' Check if there is anything underneath
If Not IsEmpty(found.Offset(1).Value) Then
Set found = Range(found.Offset(1), found.End(xlDown))
' Note the number of items if it's more that has been found so far
If maxcount < found.Count Then maxcount = found.Count
' Copy cells
Range(hdr.Offset(currentrow), hdr.Offset(currentrow + found.Count - 1)) = found.Cells.Value
End If
End If
Next hdr
' Move down ready for the next sheet
currentrow = currentrow + maxcount
Next sheet
End Sub
I wrote this in Excel 2016 and tested that it worked based on my assumption of how your data is laid out.
I am trying to loop through a range on cells in a column and then check if the cell is empty, if it is, I want to copy the corresponding row into a new sheet. This is what I have so far:
If Len(Cells(i, 17)) = 0 Then
Sheets("GES1").Activate
ActiveSheet.Range(Cells(i, 1), Cells(i, 17)).Select
Selection.Copy
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Paste
End If
Next i
The problem with this code is that as soon as there is an empty cell the corresponding row gets copied and pasted into a new sheet and the following rows also get copied and pasted into new sheets even if their corresponding cells are not blank. I want the code to copy and paste any row corresponding to an empty cell value in column Q i.e 17 to a single new sheet
Problem is with this line. Try correcting it.
Worksheets.Add after:=Sheets(Sheets.Count)
I believe that you want all of the rows with a blank column Q cell to be copied to a single new worksheet.
Sub copy_blank_to_new()
Dim i As Long, ws As Worksheet
Set ws = Worksheets.Add(after:=Sheets(Sheets.Count))
With Sheets("GES1")
.Cells(1, 1).Resize(1, 17).Copy Destination:=ws.Cells(1, 1)
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If Not CBool(Len(Cells(i, 17).Value)) Then _
.Cells(i, 1).Resize(1, 17).Copy _
Destination:=ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next i
End With
Set ws = Nothing
End Sub
That starts by copying the first row across. I've guessed that is column header label information. It then copies each row with a blank (actually zero-length value) into subsequent rows in the same new worksheet.
If column Q could be blank then there is the distinct possibility that other columns could contain blanks. I've used column A to determine the extents of the data to be examined. If this is insufficient, there are other methods but having some idea of what your data actually looks like would help.
I'm trying to fetch the data from an excel which contains a single query in each sheet.
so, here are my steps :
1) creating an excel application --> workbook --> worksheet objects
2) get all the sheet names and point to a specific sheet (which i'm doing harcoded for time being)
3) Retrieve all the rows from the sheet into an array of variants
4) finally join the each array variant into a single string
The final step i'm not able to achieve. when i'm using a for next loop i'm getting only 25 records into the string though the array has more than 25 elemets init or If I use join function for the array it's throwing a type mismatch error.
In my excel the query is always placed in multiple rows in first column itself.
To get the data into the array variable for the sheet names and actual query values i'm using a user defined push function. I want my arrays to grow dynamically based on the no. of the values.
please find my code below :
ReDim arrSheetNames(-1)
ReDim k(-1)
Dim strQry()
'create an excel application object
set myExcel =CreateObject("Excel.Application")
'create an excel workbook object
set myWorkBook=myExcel.WorkBooks.Open("D:\Test.xlsx")
'Get the sheetnames into an array
For i = 1 To myWorkBook.Sheets.Count
fnPush arrSheetNames, myWorkBook.Sheets.Item(i).Name
Next
'Get th second sheet of the excel
set mysheet = myworkbook.Worksheets(arrSheetNames(0))
'Get the max row occupied in the excel file
Row=mysheet.UsedRange.Rows.Count
'Get the max column occupied in the excel file
Col=mysheet.UsedRange.columns.count
'To read the data from the entire Excel file
For i= 1 to Row
For j=1 to Col
fnPush k,mysheet.cells(i,j).value
Next
Next
m = join (arrSheetNames)
msgbox m
this is where im getting only 25 rows added to the string however there are 33 elements in the array k.
i=0
'
For i = 0 To UBound(k) Step 1
n = n & k(i)
Next
msgbox n
when i'm using this statement it's throwing an error for type mismatch
strQry = join(k)
msgbox strQry
'Save the Workbook
'myExcel.ActiveWorkbook.Save
'Close the Workbook
myExcel.ActiveWorkbook.Close
'Close Excel
myExcel.Application.Quit
Set mysheet =nothing
Set myWorkBook = nothing
Set myExcel = nothing
sub fnPush(arr, var)
dim uba
uba = UBound(arr)
redim preserve arr(uba+1)
arr(uba+1) = var
end sub
The MsgBox function in VBScript can display a maximum of 1023 characters. I'm guessing you're reaching that limitation with your join() statement.
Replace Dim strQry() with Dim strQry, otherwise you should try to assign join result string to array that gives an error.
I need to add a section within an existing macro that takes a cell's address and looks for that address (as a string?) from the values within a range of cells elsewhere on the sheet - then offsets one column over to use that cell's value to replace the original value of the cell who's address was searched.
My code is looking for unmerged cells, and when it finds an unmerged cell, it needs to grab the correct value to put in there. Not all cells in my range mCell are unmerged, so this is a find/replace within a loop.
I cannot hard code the cells, and also cannot figure out a functional loop that successfully moves through my range and finds/replaces using values from another part of the worksheet. I'm new at VBA and keep getting errors and wind up defining a dozen ranges and strings trying to carry over the data. Any help would be greatly appreciated!
For example:
if unmerged mCell.address = "B20", then the macro finds the value "B20" in a designated range (in example below, was found in cell Q20), then offset one column over (to cell R20), then uses value of that cell (which is 6) to replace the value of mcell, such that the new cell value of B20 (i.e., the active mCell) = 6. Then on to the next unmerged mCell...
row Column Q Col. R '(not code, but can't get formatting any other way)
18 B18(text) 5
19 B19 4
20 B20 6
21 B21 3
Thank you for any suggestions, My existing code works great until "Part II", but then I'm failing miserably and am requesting specific help on how to correct/improve the code. Existing code is:
' This sub looks for the word "Table" in column A. If the word appears, it unmerges the cells in columns B - E
' and the rows following to allow for the insert of a table, then merges all other rows for sake of format.
Option Explicit
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Range("B14:E64").SpecialCells(xlCellTypeVisible).Select
With Selection
.RowHeight = 17
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
.WrapText = True
End With
'*******Merge or unmerge rows according to whether or not they contain Table data -
' this only acts on visible cells, so rows of data table can be hidden as needed
Dim TA As Integer
Dim ColValues As Variant
Dim rng As Range
Dim tabNo As Range 'uses value on worksheet to know how many rows to unmerge
'*******Dims in finding and replacing unmerged cell values
Dim mergeRange As Range 'Range B16:E64 - where my mCells are being pulled from
Dim mCell As Range 'Cell that is unmerged, looking for its address
Dim ws As Worksheet
Dim tabledata As Range 'Range Q11:Q38 - this is the column I'm searching in and offsetting from
Dim aCell As String 'picks up cell address, to use in .find
Dim myCell As Range 'cell address in Q
Dim ReplaceString As String
Dim foundCell As Range
Dim bCell As Range
Dim i As Long
Application.DisplayAlerts = False
'Make column B = Column A values, cannot make this happen on sheet, because data is too variable
ColValues = ActiveSheet.Range("A16:A64").Value
ActiveSheet.Range("B16:B64").Value = ColValues
'Look for data table, if not present, merge cells
Set rng = ActiveSheet.Range("B14:B100")
Set tabNo = ActiveSheet.Range("K6")
For TA = 15 To 64 'defines TA variable to loop from row 14 to row 64
If Cells(TA, "A") = "Table" Then '
Range("B" & TA & ":E" & TA + tabNo).UnMerge 'unmerges the row with "Table" listed and the next 7 rows (to make a 8-row x 4 column unmerged area for table
TA = TA + tabNo ' moves active cell "TA" down 7 spaces
Else
Range("B" & TA & ":E" & TA).Merge 'If "Table" not found, then merge the cells for the row TA is in across columns B:E
End If
Next TA
'*** Part II: Need some calculation to loop or offset or find through data and fill
'unmerged cells from a data table on the worksheet.
'the placement of the data table varies depending on the layout of the report,
'which changes day to day, so can not be hard coded into the cells - needs to look up
'position of the word "Table" and dump data after that.
'offset? .find? loop?
'***want to take the cell address of each unmerged cell within the range of the report
'and look for that cell in an array, then replace the cell contents with the correct value
Set mergeRange = ActiveSheet.Range("B16:E64")
For Each mCell In mergeRange
' If mergeRange.MergeCells = True Then
' MsgBox "all cells are merged, exiting sub"
' Exit Sub
'Else
If mCell.MergeCells = False Then
aCell = mCell.Address '??? Need to set the cell address as
'a text string or something in order to look for that address in the values
'of cells in range "tabledata"
'MsgBox "aCell " & Range(aCell).Address
Set tabledata = ActiveSheet.Range("Q11:Q38")
Set bCell = tabledata.Find(aCell, After:=Range("Q1"), LookIn:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
'this gives me a "type mismatch" error that I cannot clear
'- then wanting the value of the cell offset one column over
'need to take the value of that offset cell and use it
'to replace the value of the original unmerged cell (mCell)
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
Next mCell
End Sub
There were a few problems in there but I think it's working now. You'll have to verify as I'm still not 100% sure what it is supposed to do.
Problem 1: You don't need tabledata. You specify in the search parameters After:=Range("Q1") so it's looking in the right place. Find works on a Cells so your line should be:
Set bCell = Cells.Find(aCell, After:=Range("Q1"), LookIn:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Problem 2: Your line aCell = mCell.Address needs to be aCell = Replace(mCell.Address, "$", "") as it comes in as an absolute cell reference and the cell address on your sheet are not (probably a more elegant way of doing this).
There were a couple of other problems in your Dropbox file but those should be sorted too now. There was an extra Next and the line aCell.Offset(, 1) = bCell.Offset(, 1) seems like it should be mCell.Offset(, 1) = bCell.Offset(, 1).
https://www.dropbox.com/s/jqdg3v0gd59mxjn/Test%20Workbook%201016jb.xlsm