kindly refer to this link from which this Array code was "improved upon", but which cant work due to "object code error". The array code was untested by the coder.
PICK OUT/EXTRACT column header "COMMON" IN ALL 5 SHEETS
Kindly help out.
PICK OUT/EXTRACT column header "COMMON" IN ALL 5 SHEETS
Code:
Sub FindAll2()
Dim lr As Long 'Last row in Wk1
Dim nr As Long ' next available row in New All
Dim i As Integer 'counter for worksheets
Dim outarr As Variant
On Error GoTo errHandle
Application.EnableEvents = False
Application.ScreenUpdating = False
' load all 5 sheets into varaint arrays
lr1 = Worksheets("Wk1").Range("A" & Rows.Count).End(xlUp).Row
w1arr = Worksheets("Wk1").Range(Cells(1, 1), Cells(lr1, 26)) ' I put 26 columns in because you wanted to check columnn z
lr2 = Worksheets("Wk2").Range("A" & Rows.Count).End(xlUp).Row
w2arr = Worksheets("Wk2").Range(Cells(1, 1), Cells(lr2, 26)) ' I put 26 columns in because you wanted to check columnn z
lr3 = Worksheets("Wk3").Range("A" & Rows.Count).End(xlUp).Row
w3arr = Worksheets("Wk3").Range(Cells(1, 1), Cells(lr3, 26)) ' I put 26 columns in because you wanted to check columnn z
lr4 = Worksheets("Wk4").Range("A" & Rows.Count).End(xlUp).Row
w4arr = Worksheets("Wk4").Range(Cells(1, 1), Cells(lr4, 26)) ' I put 26 columns in because you wanted to check columnn z
lr5 = Worksheets("Wk5").Range("A" & Rows.Count).End(xlUp).Row
w5arr = Worksheets("Wk5").Range(Cells(1, 1), Cells(lr5, 26)) ' I put 26 columns in because you wanted to check columnn z
nr = Worksheets("New All").Range("A" & Rows.Count).End(xlUp).Row + 1
ReDim outarr(1 To lr1, 1 To 26)
'Get Names range
' Set rNames = Worksheets("Wk1").Range("B2:B" & lr)
indi = 1
For i = 1 To lr1
wkcnt = 0
thisname = w1arr(i, 2) ' column b of first worksheet
For j = 1 To lr2
If thisname = w2arr(j, 2) Then
wkcnt = wkcnt + 1
Exit For
End If
Next j
For j = 1 To lr3
If thisname = w3arr(j, 2) Then
wkcnt = wkcnt + 1
Exit For
End If
Next j
For j = 1 To lr4
If thisname = w4arr(j, 2) Then
wkcnt = wkcnt + 1
Exit For
End If
Next j
For j = 1 To lr5
If thisname = w5arr(j, 2) Then
wkcnt = wkcnt + 1
Exit For
End If
Next j
If wkcnt = 4 Then
'only get here if name is found in each sheet
' copy input row to output array
For kk = 1 To 26
outarr(indi, kk) = w1arr(i, kk)
Next kk
indi = indi + 1
End If
Next i
' write output array to workhseet
Worksheets("New All").Range(Cells(nr, 1), Cells(nr + indi, 26)) = outarr
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
errHandle:
MsgBox Err.Description, vbCritical, Err.Number
Application.EnableEvents = True
Application.ScreenUpdating = True
End SubKindly help out.
