Forum Discussion

dqzk610's avatar
dqzk610
Copper Contributor
Aug 17, 2021
Solved

Traverse Multiple Sheets and Copy Unique Data to Summary

I'm trying to create a macro which performs the following actions when executed:

 

1: Searches sheets "Exterior" and "Interior"
2: Checks column "E" for value "Submitted"
3: If unique, copy columns A:E for that entry to sheet "Tracking"

4: If the Part Number already exists on sheet "Tracking" do not copy
5: Assigns a tracking number (next available in sequence) in column "F" on sheet "Tracking"

 

The idea being that the macro could be ran multiple times, but it will be smart enough not to copy the same data multiple times. The tracking sheet should only show items that have a "Submitted" status.

 

I've created a dummy workbook due to the sensitive nature of the actual data. It's worth mentioning that every "Part Number" is unique.

 

excel
Macros and VBA
  • HansVogelaar's avatar
    HansVogelaar
    Aug 17, 2021

    dqzk610 

    Here you go:

     

    Sub CopySubmittedRecords()
    Dim wss As Worksheet
    Dim wst As Worksheet
    Dim t As Long
    Dim rng As Range
    Dim adr As String
    Application.ScreenUpdating = False
    Set wst = Worksheets("Tracking")
    t = wst.Range("A" & wst.Rows.Count).End(xlUp).Row
    For Each wss In Worksheets(Array("Exterior", "Interior"))
        With wss.Range("E:E")
            Set rng = .Find(What:="Submitted", LookAt:=xlWhole)
            If Not rng Is Nothing Then
                adr = rng.Address
                Do
                    If wst.Range("A:A").Find(What:=rng.Offset(0, -4).Value, LookAt:=xlWhole) Is Nothing Then
                        t = t + 1
                        wst.Range("A" & t).Resize(1, 5).Value = rng.Offset(0, -4).Resize(1, 5).Value
                        If Not IsNumeric(wst.Range("F" & t - 1).Value) Then
                             wst.Range("F" & t).Value = 5000 ' or whichever starting number you prefer
                       Else
                            wst.Range("F" & t).Value = wst.Range("F" & t - 1).Value + 1
                        End If
                    End If
                    Set rng = .FindNext(After:=rng)
                    If rng Is Nothing Then Exit Do
                Loop Until rng.Address = adr
            End If
        End With
    Next wss
    Application.ScreenUpdating = True
End Sub

     

2 Replies

  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Aug 17, 2021

    dqzk610 

    Here you go:

     

    Sub CopySubmittedRecords()
    Dim wss As Worksheet
    Dim wst As Worksheet
    Dim t As Long
    Dim rng As Range
    Dim adr As String
    Application.ScreenUpdating = False
    Set wst = Worksheets("Tracking")
    t = wst.Range("A" & wst.Rows.Count).End(xlUp).Row
    For Each wss In Worksheets(Array("Exterior", "Interior"))
        With wss.Range("E:E")
            Set rng = .Find(What:="Submitted", LookAt:=xlWhole)
            If Not rng Is Nothing Then
                adr = rng.Address
                Do
                    If wst.Range("A:A").Find(What:=rng.Offset(0, -4).Value, LookAt:=xlWhole) Is Nothing Then
                        t = t + 1
                        wst.Range("A" & t).Resize(1, 5).Value = rng.Offset(0, -4).Resize(1, 5).Value
                        If Not IsNumeric(wst.Range("F" & t - 1).Value) Then
                             wst.Range("F" & t).Value = 5000 ' or whichever starting number you prefer
                       Else
                            wst.Range("F" & t).Value = wst.Range("F" & t - 1).Value + 1
                        End If
                    End If
                    Set rng = .FindNext(After:=rng)
                    If rng Is Nothing Then Exit Do
                Loop Until rng.Address = adr
            End If
        End With
    Next wss
    Application.ScreenUpdating = True
End Sub

     

    • dqzk610's avatar
      dqzk610
      Copper Contributor
      Aug 18, 2021
      I never expected such a thorough, working response so quickly. Thank you very much for your time HansVogelaar

Resources