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

 

[Alex Blakenburg]

If you are still not there yet, why not give @DanteAmor's code a try.
Although you can't use the dictionary on Mac OS, the code can be modified to use a collection.
Make sure you copy in both the Sub & the Function.

Sub Macro_v1_dante_coll()
  Dim coll As New Collection
  Dim sKey As String
  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 coll = CreateObject("Scripting.colltionary")
  'Set coll = New Collection
  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)
    sKey = CStr(a(i, 1))
    On Error Resume Next
    coll.Add key:=sKey, Item:=(i - 2)
    On Error GoTo 0
  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
        sKey = CStr(c(i, 7))
        If Exists(coll, sKey) Then                'Matching ID number found
          Dn = c(i, 1)
          If Dn >= 1 And Dn <= 6 Then
            b(coll(sKey), 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

Function Exists(coll As Collection, ByVal key As String)

    On Error GoTo EH
    IsObject (coll.Item(key))
    Exists = True

EH:
End Function

 

[TAPS_MikeDion]

Hi everybody,
I'm so sorry I never got back to anyone on this until now; I thought I did. I ran out of time and just used what I had...it works.

Thank you!