Help needed with making a faster, more efficient VBA code

[TAPS_MikeDion]

Hello everybody,
This code does work, but I'm betting it can be shortened to be faster and more efficient since I'm not that well versed in VBA coding. Would anyone be willing to help me with that?

I greatly appreciate any help given. If the spreadsheets will be needed to "recreate" the code, I'll have to post them with bugus data tomorrow.

Thank you!

With Sheets("Division Member Info")
    .Range("AJ3:AO500").ClearContents
    For Each c In .Range("D3", .Range("D" & Rows.Count).End(3))
      For Each sh In Sheets
        If UCase(Left(sh.Name, 2)) = "D-" Then
          IDr = sh.Cells(Rows.Count, 7).End(xlUp).Row
          'Get last row with an ID number
          If IDr > 1 Then
            'There is at least 1 ID number
            For n = 2 To IDr
              'Loop through ID numbers
              If c = sh.Range("G" & n) Then
                'Matching ID number found
                Dn = sh.Range("A" & n).Value
                'Dn is assigned the value of the Detail / Event # in column A of the DMI sheet
                Select Case Dn
                'Place an X in the appropriate Detail / Event # row for the matching ID in the DMI sheet
                  Case 1
                    'Road Race
                    .Range("AJ" & c.Row).Value = "X"
                  Case 2
                    'Parade
                    .Range("AK" & c.Row).Value = "X"
                  Case 3
                    'Fireworks
                    .Range("AL" & c.Row).Value = "X"
                  Case 4
                    'Fiestas Patronales
                    .Range("AM" & c.Row).Value = "X"
                  Case 5
                    'Celebrate Holyoke
                    .Range("AN" & c.Row).Value = "X"
                  Case 6
                    'Tree Lighting
                    .Range("AO" & c.Row).Value = "X"""
                End Select
              End If
            Next
          End If
        End If
      Next
    Next
  End With

 

[JEC]

Would be something like this

Sub jec()
 Dim ar, ar2, sh, j As Long, jj As Long
 With Sheets("Division Member Info")
   .Range("AJ3:AO500").ClearContents
    ar = .Range("D3", .Range("D" & Rows.Count).End(3)).Resize(, 38)
    For j = 1 To UBound(ar)
      For Each sh In Sheets
        If UCase(Left(sh.Name, 2)) = "D-" Then
          ar2 = sh.Range("A", sh.Range("A" & Rows.Count).End(xlUp)).Resize(, 7)
          If UBound(ar2) > 1 Then
            For jj = 2 To UBound(ar2)
              If ar(j, 1) = ar2(jj, 7) Then
                ar(j, 32 + ar2(jj, 1)) = "X"
                Exit For
              End If
            Next
          End If
        End If
      Next
    Next
  .Range("D3", .Range("D" & Rows.Count).End(3)).Resize(, 38) = ar
 End With
End Sub

 

[Jeffrey Mahoney]

I wasn't able to test very much, but we could work through the errors.

Sub IDunno()

  Dim u As Range
  Dim cArray As Variant
  Dim AryCnt As Long
  Dim c As Long
  Dim n As Long
  Dim IDr As Long
 
  With Sheets("Division Member Info")
      .Range("AJ3:AO500").ClearContents
      cArray = Application.Transpose(.Range("D3", .Range("D" & Rows.Count).End(xlUp)))
      AryCnt = UBound(cArray)
     
        For Each sh In ThisWorkbook.Sheets
          If UCase(Left(sh.Name, 2)) = "D-" Then
            IDr = sh.Cells(Rows.Count, 7).End(xlUp).Row     'Get last row with an ID number
            If IDr > 1 Then                                 'There is at least 1 ID number
              For n = 2 To IDr                              'Loop through the values from main worksheet
               
                For c = 1 To AryCnt                         'Loop through ID numbers
                  If cArray(c) = sh.Range("G" & n) Then     'Matching ID number found
                    dn = sh.Range("A" & n).Value            'Dn is assigned the value of the Detail / Event # in column A of the DMI sheet
                    If Not u Is Nothing Then                'Add cell to u range
                      Set u = Union(u, .Range("AI" & c + 2).Offset(0, dn))
                    Else
                      Set u = .Range("AI" & c + 2).Offset(0, dn)
                    End If
                    Exit For
                  End If
                  
                Next c
             
              Next n
            End If
          End If
        Next
       
        If Not u Is Nothing Then u.Value = "X"    'Put all the Xs in place at one time
     
    End With
 
End Sub

 

[DanteAmor]

Here is another macro for you to consider:

Sub Macro_v1()
  Dim dic As Object
  Dim i As Long, IDr As Long
  Dim sh As Worksheet, sh1 As Worksheet
  Dim a As Variant, b As Variant, c As Variant, Dn As Variant

  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = Sheets("Division Member Info")
  
  a = sh1.Range("D1", sh1.Range("D" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 6)
  For i = 3 To UBound(a, 1)
    dic(a(i, 1)) = i - 2
  Next
      
  For Each sh In Sheets
    If UCase(Left(sh.Name, 2)) = "D-" Then
      c = sh.Range("A1:G" & sh.Cells(Rows.Count, "G").End(xlUp).row + 1).Value
      For i = 2 To UBound(c, 1)                     'Loop through ID numbers
        If dic.exists(c(i, 7)) Then                 'Matching ID number found
          Dn = c(i, 1)
          If Dn >= 1 And Dn <= 6 Then
            b(dic(c(i, 7)), Dn) = "X"
          End If
        End If
      Next i
    End If
  Next sh
  
  sh1.Range("AJ3").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

 

[TAPS_MikeDion]

Thank you to all of the responses!!!

I will try these in a little while.

MUCH APPRECIATED!

 

[TAPS_MikeDion]

BTW, I realize it's posted on the left with my avatar, but will all of these work with MacOS Office Version 2011?

Thank you.

 

[JEC]

Dictionary approach isn’t working on macs

 

[TAPS_MikeDion]

Thanks for the heads-up J.

 

[TAPS_MikeDion]

Hi JEC,
I tried your code, but when it reaches the point of finding the "D-" sheets it errors out stating Run-Time error 1004. Not every D- sheet has data in column A starting at row 2. That is why in my original code I used the following to make sure there was at least one row with an ID number or I would get the same error:

IDr = sh.Cells(Rows.Count, 7).End(xlUp).Row
          'Get last row with an ID number
          If IDr > 1 Then

I didn't want to mess with your code and make matters worse so I haven't made any changes. Having it debug to the line of code:

          ar2 = sh.Range("A", sh.Range("A" & Rows.Count).End(xlUp)).Resize(, 7)

shows that ar2 = empty when it loops to the first D- sheet, which has no ID number data in it. As soon as it executes that line of code is when the error occurs.

 

[JEC]

It is hard to code without example
I kind of guessed the ranges