I am trying to gather data from dozens of worksheets in a workbook and compile them all to be appended to a new master workbook.
This line: ReDim varArray2 (1 To UBound(varArray, 2), 1 To UBound(varArray, 1)) keeps clearing out my preserved data from all worksheets when I try to make an overarching varArray2 to print all arrays at once to the new master worksheet.
What is causing the array to clear out and how can I fix it?
Option Explicit
Sub ws_Merge()
Dim k As Long, x As Long, j As Long
Dim varArray() As Variant
Dim varArray2() As Variant
ReDim varArray(1 To 11, 1 To 1)
Dim ws As Worksheet, wb As Workbook
Set wb = ThisWorkbook
For Each ws In Worksheets
With wb.ActiveSheet
For j = 2 To .UsedRange.Rows.Count + 1
If .Cells(j, 1) <> "" Then
x = x + 1
ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(j, k)
Next
End If
Next
End With
Next ws
ReDim varArray2(1 To UBound(varArray, 2), 1 To UBound(varArray, 1))
With ThisWorkbook.Sheets.Add
For j = 1 To UBound(varArray, 2)
For k = 1 To UBound(varArray, 1)
varArray2(j, k) = varArray(k, j)
Next
Next
.Range(.Cells(2, 1), .Cells(UBound(varArray, 2), UBound(varArray, 1))) = varArray2
End With
End Sub
Related
I have a script I use that goes down a column in a second worksheet and pulls only the managers (their employees data) that I specify.
It takes about .8-.9 seconds for each file to form from both arrays (one for storing and the second for a faster printing to a new wb)
Are there any revisions you would make in order to drastically speed it up? I know that the majority of the time spent is saving/password protecting.
script:
Option Explicit
Sub HR_Assessment()
Dim j As Long, k As Long, x As Long ' counters
Dim varArray() As Variant
Dim varArray2() As Variant
ReDim varArray(1 To 75, 1 To 1)
Dim strManager As String
Dim BASEPATH As String, strNewPath As String, strFileName As String
Dim Wb As Workbook
Dim mgrRow As Long ' counter
Dim colManager As Long ' the column manager appears in
colManager = 1
BASEPATH = "M:\Raw Reports\HR\"
Call Ludicrous(True) - this is just a separate module that turns off calculations/screen updating/etc....
For mgrRow = 2 To ThisWorkbook.Worksheets("Mgrs").UsedRange.Rows.Count
If ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 1) <> "" Then
strManager = ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 1)
With ThisWorkbook.Worksheets("Sheet1")
ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
x = 1
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(1, k)
Next
For j = 1 To .UsedRange.Rows.Count + 1
If strManager = .Cells(j, colManager) Then
x = x + 1
ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(j, k)
strManager = .Cells(j, colManager)
Next
End If
Next
End With
strNewPath = BASEPATH & "11.01.18" & "\"
If Len(Dir(strNewPath, vbDirectory)) = 0 Then
MkDir strNewPath
End If
' Path is now "constant path"
strFileName = strManager & " - " & "HR_Assessment" & ".xlsx"
ReDim varArray2(1 To UBound(varArray, 2), 1 To UBound(varArray, 1))
Set Wb = Workbooks.Add(XlWBATemplate.xlWBATWorksheet)
With Wb
With .Worksheets("Sheet1")
For j = 1 To UBound(varArray, 2)
For k = 1 To UBound(varArray, 1)
varArray2(j, k) = varArray(k, j)
Next
Next
.Range(.Cells(1, 1), .Cells(UBound(varArray, 2), UBound(varArray, 1))) = varArray2
.Range("A:B").Columns.AutoFit
End With
.SaveAs strNewPath & strFileName, Password:="password", FileFormat:=51
.Saved = True
.Close
End With
Set Wb = Nothing
End If
Next
Call Ludicrous(False)
End Sub
So I have a master sheet with 1000+ rows and another sheet that "should" have the same data. however, in reality sometimes some is missing from the master and sometimes some is missing from the query run.
for simplicity purposes let's say the unique ID is in column B. here's my code but it's super slow and it only does a 1-way comparison.
My ideal code would be something that runs a little smoother and gives me the missing data from both the master and the query.
Is there's something wrong with the way I'm asking the question please let me know.
Sub FindMissing()
Dim lastRowE As Integer
Dim lastRowF As Integer
Dim lastRowM As Integer
Dim foundTrue As Boolean
lastRowE = Sheets("Master").Cells(Sheets("Master").Rows.Count, "B").End(xlUp).Row
lastRowF = Sheets("Qry").Cells(Sheets("Qry").Rows.Count, "B").End(xlUp).Row
lastRowM = Sheets("Mismatch").Cells(Sheets("Mismatch").Rows.Count, "B").End(xlUp).Row
For i = 1 To lastRowE
foundTrue = False
For j = 1 To lastRowF
If Sheets("Master").Cells(i, 2).Value = Sheets("Qry").Cells(j, 2).Value Then
foundTrue = True
Exit For
End If
Next j
If Not foundTrue Then
Sheets("Master").Rows(i).Copy Destination:= _
Sheets("Mismatch").Rows(lastRowM + 1)
lastRowM = lastRowM + 1
End If
Next i
End Sub
Don't loop through the cells on the worksheet. Collect all of the values into variant arrays and process in-memory.
Option Explicit
Sub YouSuckAtVBA()
Dim i As Long, mm As Long
Dim valsM As Variant, valsQ As Variant, valsMM As Variant
With Worksheets("Master")
valsM = .Range(.Cells(1, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
With Worksheets("Qry")
valsQ = .Range(.Cells(1, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
ReDim valsMM(1 To (UBound(valsM, 1) + UBound(valsQ, 1)), 1 To 2)
mm = 1
valsMM(mm, 1) = "value"
valsMM(mm, 2) = "missing from"
For i = LBound(valsM, 1) To UBound(valsM, 1)
If IsError(Application.Match(valsM(i, 1), valsQ, 0)) Then
mm = mm + 1
valsMM(mm, 1) = valsM(i, 1)
valsMM(mm, 2) = "qry"
End If
Next i
For i = LBound(valsQ, 1) To UBound(valsQ, 1)
If IsError(Application.Match(valsQ(i, 1), valsM, 0)) Then
mm = mm + 1
valsMM(mm, 1) = valsQ(i, 1)
valsMM(mm, 2) = "master"
End If
Next i
valsMM = helperResizeArray(valsMM, mm)
With Worksheets("Mismatch")
With .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
.Resize(UBound(valsMM, 1), UBound(valsMM, 2)) = valsMM
End With
End With
End Sub
Function helperResizeArray(vals As Variant, x As Long)
Dim arr As Variant, i As Long
ReDim arr(1 To x, 1 To 2)
For i = LBound(arr, 1) To UBound(arr, 1)
arr(i, 1) = vals(i, 1)
arr(i, 2) = vals(i, 2)
Next i
helperResizeArray = arr
End Function
You cannot resize the first rank of a 2D array so I've added a helper function that will resize the results before putting them back into the Mismatch worksheet.
I am looking for a VBA solution to transform data from a scenario similar to the illustration below. From Sheet1 copy first three cell values (A3,B3,C3) only if there is a value in any cell to the left of them (D3,E3,...) in Sheet2 past first 3 cell values (A2,B2,C2), and the first cell after that with a value (D3) and also copy the header value into the adjacent cell. Any additional values to the left get the same treatment and become the next row, again copying (A3,B3,C3). Then the next adjacent cell value (E3) along with the header value into the adjacent cell. Then move down to the next row in Sheet1 where there are values after the first 3 cells until it has looped all the way through sheet1 to produce the example in Sheet2.
I have searched for other similar solutions but cannot find anything that works. This is the closest I've found with minor edits on my part but doesn’t work, any help is greatly appreciated.
Sub Sample()
Dim wsThis As Worksheet
Dim wsThat As Worksheet
Dim ThisAr As Variant
Dim ThatAr As Variant
Dim Lrow As Long
Dim Col As Long
Dim i As Long
Dim k As Long
Set wsThis = Sheet1: Set wsThat = Sheet2
With wsThis
'~~> Find Last Row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Find total value in D,E,F so that we can define output array
Col = Application.WorksheetFunction.CountA(.Range("C2:G" & Lrow))
'~~> Store the values from the range in an array
ThisAr = .Range("A2:G" & Lrow).Value
'~~> Define your new array
ReDim ThatAr(1 To Col, 1 To 7)
'~~> Loop through the array and store values in new array
For i = LBound(ThisAr) To UBound(ThisAr)
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
'~~> Check for Color 1
If ThisAr(i, 5) <> "" Then 'ThatAr(k, 4) = ThisAr(i, 4)
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 4) = ThisAr(i, 4)
ThatAr(k, 5) = ThisAr(i, 5)
End If
'~~> Check for Color 2
If ThisAr(i, 7) <> "" Then
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 6) = ThisAr(i, 6)
ThatAr(k, 7) = ThisAr(i, 7)
End If
'~~> Check for Color 3
'If ThisAr(i, 6) <> "" Then
'k = k + 1
'ThatAr(k, 1) = ThisAr(i, 1)
'ThatAr(k, 2) = ThisAr(i, 2)
'ThatAr(k, 3) = ThisAr(i, 3)
'ThatAr(k, 4) = ThisAr(i, 6)
'End If
Next i
End With
'~~> Create headers in Sheet2
Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value
'~~> Output the array
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
End Sub
Using a variant array(dynamic array) is simple and fast.
Sub test()
Dim wsThis As Worksheet, wsThat As Worksheet
Dim vDB As Variant, vR() As Variant
Dim r As Long, i As Long, n As Long
Dim c As Integer, j As Integer, k As Integer
Set wsThis = Sheet1: Set wsThat = Sheet2
vDB = wsThis.Range("a1").CurrentRegion
r = UBound(vDB, 1)
c = UBound(vDB, 2)
For i = 2 To r
For j = 4 To c
If vDB(i, j) <> "" Then
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
For k = 1 To 3
vR(k, n) = vDB(i, k)
Next k
vR(4, n) = vDB(i, j)
vR(5, n) = vDB(1, j)
End If
Next j
Next i
With wsThat
.UsedRange.Clear
.Range("a1").Resize(1, 3) = wsThis.Range("a1").Resize(1, 3).Value
.Range("d1").Resize(1, 2) = Array("Value", "ID#")
.Range("a2").Resize(n, 5) = WorksheetFunction.Transpose(vR)
End With
End Sub
Sorry, I'm not sure why I couldn't open your attached images.
But you might want to try this code:
Change this line:
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
To
wsThat.Range("A2").Resize(4, Col).Value = WorksheetFunction.Transpose(ThatAr)
Hope this help
my program is giving error
Sub my()
Dim j As Integer
Dim i As Integer
For i = 1 To 8
For j = 1 To 4
If Sheet1.Cells(i, 1) <> Sheet2.Cells(j, 1) Then
Sheet1.Cells(i, 2) = Sheet2.Cells(j, 2)
End If
Next j
Next i
End Sub
it gives an error object required
can someone tell me what is wrong in it i am new in VBA
You can try like this:
Dim j As Integer
Dim i As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
For i = 1 To 8
For j = 1 To 4
If ws1.Cells(i, 1) <> ws2.Cells(j, 1) Then
ws1.Cells(i, 2) = ws2.Cells(j, 2)
End If
Next j
Next i
I need help.
In a sheet I need concatenate with a loop the columns "a" + "b" + "c", next the columns "d" + "e" + "f", etc ... an go up to the last column.
My script is locked to the second loop...
The concatenated results are to appear in a second sheet.
this is my incorrect code:
Sub concatena()
Dim x As String
Dim Y As String
b = 1 'colonna selezionata
For c = 1 To 5 'colonne concatenate da riportare
For q = 1 To 10 'righe su cui effettuare l'operazione
For t = 1 To 3 'numero celle da concatenare
For Each cell In Worksheets(1).Cells(q, t)
If cell.Value = "" Then GoTo Line1
x = x & cell(1, b).Value & "" & ""
Next
Next t
Line1:
On Error GoTo Terminate
Worksheets(2).Cells(q, c).Value = Mid(x, 1, Len(x))
x = "" 'mantiene la formattazione
Next q
b = 3 + 1 ' sposta il concatena di 3 celle la selezione delle colonne
Next c
Terminate: 'error handler
End Sub
Thank you all for the help!
This one uses arrays to speed it up a little:
Sub concatena()
Dim inArr() As Variant
Dim oArr() As Variant
Dim i&, j&
Dim ws As Worksheet
Dim rng As Range
Set ws = Worksheets("Sheet9") ' change to your worksheet
With ws
Set rng = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
inArr = rng.Value
ReDim oArr(1 To UBound(inArr, 1), 1 To UBound(inArr, 2) / 3)
For i = LBound(inArr, 1) To UBound(inArr, 1)
For j = LBound(inArr, 2) To UBound(inArr, 2) Step 3
oArr(i, Int((j - 1) / 3) + 1) = inArr(i, j) & inArr(i, j + 1) & inArr(i, j + 2)
Next j
Next i
rng.Clear
.Range("A1").Resize(UBound(oArr, 1), UBound(oArr, 2)).Value = oArr
End With
you can try this code:
Option Explicit
Sub concatena()
Dim iRow As Long, iCol As Long, iCol2 As Long
Dim arr As Variant
With Worksheets("numbers")
With .Cells(1, 1).CurrentRegion
ReDim arr(1 To .Rows.Count, 1 To .Columns.Count / 3 + .Columns.Count Mod 3)
For iRow = 1 To .Rows.Count
iCol2 = 1
For iCol = 1 To .Columns.Count Step 3
arr(iRow, iCol2) = Join(Application.Transpose(Application.Transpose(.Cells(iRow, iCol).Resize(, 3).Value)), "")
iCol2 = iCol2 + 1
Next iCol
Next iRow
Worksheets("results").Range("A1").Resize(.Rows.Count, UBound(arr, 2)).Value = arr
End With
End With
End Sub
This solution provides flexibility as it uses the variable bClls to hold the number of cells to be concatenated.
Assuming the source range is B2:M16 and you want to concatenate the value of every 3 cells for each row.
It avoids the use of redim.
Sub Range_Concatenate_Cells_TEST()
Dim rSel As Range
Dim bClls As Byte
Dim rCllOut As Range
bClls = 3 'change as required
Set rSel = ThisWorkbook.Sheets("Sht(0)").Range("B2:M16") 'change as required
Set rCllOut = ThisWorkbook.Sheets("Sht(1)").Cells(2, 2) 'change as required
Call Range_Concatenate_Cells(bClls, rSel, rCllOut)
End Sub
Sub Range_Concatenate_Cells(bClls As Byte, rSel As Range, rCllOut As Range)
Dim lRow As Long, iCol As Integer
Dim lRowOut As Long, iColOut As Integer
Dim vResult As Variant
With rSel
For lRow = 1 To .Rows.Count
lRowOut = 1 + lRowOut
iColOut = 0
For iCol = 1 To .Columns.Count Step 3
iColOut = 1 + iColOut
vResult = .Cells(lRow, iCol).Resize(1, 3).Value2
vResult = WorksheetFunction.Index(vResult, 0, 0)
vResult = Join(vResult, "")
rCllOut.Offset(-1 + lRowOut, -1 + iColOut).Value = vResult
Next: Next: End With
End Sub