Array code not written correctly

panyagak

Active Member
Joined
Feb 24, 2017
Messages
271
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


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 Sub

Kindly help out.
 

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,091
Office Version
  1. 2013
Platform
  1. Windows
I see
What about Column A
I' afraid it is empty, Is it?
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

panyagak

Active Member
Joined
Feb 24, 2017
Messages
271
plus what happened to exclusion of:

Code:
Dim rNames As Range, Name As Range, rFound As Range

rNames has no Dim: May be

Code:
Dim rNames As String
 

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,091
Office Version
  1. 2013
Platform
  1. Windows
I'm kind of lost
So try to change

With Worksheets("New All")
.Cells(nr, 1).Resize(UBound(aoutarr), UBound(aoutarr, 1)) = aoutarr
End With
VBA Code:
 

panyagak

Active Member
Joined
Feb 24, 2017
Messages
271

ADVERTISEMENT

I'm kind of lost
So try to change

With Worksheets("New All")
.Cells(nr, 1).Resize(UBound(aoutarr), UBound(aoutarr, 1)) = aoutarr
End With
VBA Code:

mohadin

Compare Original code in the link ( the 1st Dim line code: that Dim (of names) is missing in your Arrays code

thanks
 

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,091
Office Version
  1. 2013
Platform
  1. Windows
I cant see the point
Possible to upload as sample of you book on One drive or Dropbox?
 

panyagak

Active Member
Joined
Feb 24, 2017
Messages
271

ADVERTISEMENT

I cant see the point
Possible to upload as sample of you book on One drive or Dropbox?

Mohadin

Check this missing Dim (& why) in your code:
It isn't Declared: Dim rNames As ........

Get Names range
Code:
' Set rNames = Worksheets("Wk1").Range("B2:B" & lr)

The file is in PC can't fit in a smartphone

Regards
 

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,091
Office Version
  1. 2013
Platform
  1. Windows
Right case when you switch to Array the find method is not applicable for array
 

panyagak

Active Member
Joined
Feb 24, 2017
Messages
271
Right case when you switch to Array the find method is not applicable for array
Mohadin
The earlier non-array code is:

Code:
Dim rNames As Range, Name As Range, rFound As Range

NB: the Loop focus is on:B:B
What happens when code transforms to Array code in terms of Dims or any other changes to the Dim above?

THAT COULD BE THE BIG PROBLEM
Regards
 

panyagak

Active Member
Joined
Feb 24, 2017
Messages
271
Thanks mohadin.

I tried out the code and various suggestions though in Wk1 & Wk2 only: only the header row outputted in New ALL.

I SUSPECT THIS: My Column B consists of Text (String) and Numbers (Values) all CONCATENATED TOGETHER hence its not A HOMOGENOUS Coln.

Just did did lots of reading on Arrays

regards

Something close to this for Wk1, Wk2 only:


Code:
Sub FindAll2()
    Dim rNames As Range 
    Dim lr As Long    'Last row in Wk1
    Dim nr As Long    ' next available row in New All
    Dim lr1, lr2, lr3, lr4, lr5 ,j,kk, wkcnt, indi As Long 
    Dim i As Integer    'counter for worksheets
    Dim outarr As Variant
    Dim w1arr As Variant
    Dim w2arr As Variant
    Dim w3arr As Variant
    Dim w4arr As Variant
    Dim w5arr As Variant
    Dim thisname 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").Cells(1, 1).Resize(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").Cells(1, 1).Resize(lr2, 26)

    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
        
        If wkcnt = 1 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
    With Worksheets("New All")
.Cells(nr, 1).Resize(nr + indi, 26) = outarr
End With 

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

errHandle:
    MsgBox Err.Description, vbCritical, Err.Number
'    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,130,030
Messages
5,639,641
Members
417,101
Latest member
amoverton2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top