Combine a single Column of data from multiple sheets with VBA/Macro

[Teffi]

Hello!

I am very new at VBA I have tried some varies codes to get the results I am looking for, but I keep failing to get to my ultimate goal.

Goal 1 = I would love that all the data from a single specific column (B) on each sheet with a "date" as the sheet name in the workbook to be copied to a specific sheet, "Duplicate Audit". There are 3 sheets that are utilized for data analysis that I want to have excluded from pulling into the macro.

Goal 2 = A new sheet is added to the workbook daily so I would like when that new sheet is added the data from the specific column (B) is automatically added to the list of the already combined data. If a button can be created to have the macro run to add this new data would be great as well.

I need all column B data (minus header row) from each sheet to copy and paste to the Sheet named "Duplicate Audit" starting at A2 and then each day a new sheet is added the data in column B is added to this list on the dup audit sheet.

I don't know if this will be an issue, but we have to protect the workbook each day as there are users that can access this data, but they are only allowed to view or on a specific sheet modify a specific set of unlocked columns

Last thing, my companies IT department is not allowing us to use any Power Queary options, so I need to steer clear of those features.

Thank you in advanced for your assistance and any guidance you can provide.

 

[Sam_D_Ben]

Please try this,

Sub Teffi()
Dim a$, b&, c&, d&, e&, f&, g&, h&, i&, j&, k&, l&, m&, n&, o&, p&, q&, r&, s&, t&, u&, v&, w&, x&
Dim y As Worksheet, z As Worksheet, aa As Object, ab As Range, ac As Variant, ad As Variant
Dim ae$, af$, ag$, ah As Boolean, ai As Variant
Application.ScreenUpdating = False: Application.EnableEvents = False
Set z = ThisWorkbook.Sheets("Duplicate Audit")
If z.ProtectContents Then MsgBox "?Please unprotect the 'Duplicate Audit' sheet", _
vbExclamation, "Sheet Protected": Exit Sub
Set aa = CreateObject("Scripting.Dictionary")
b = z.Cells(z.Rows.Count, 1).End(xlUp).Row
If z.Cells(1, 1).Value = "" Then z.Cells(1, 1).Value = "UNIT": z.Cells(1, 2).Value = "DATE": b = 1
For c = 2 To b
If IsDate(z.Cells(c, 2).Value) Then
ae = Trim(z.Cells(c, 1).Value) & "|" & CLng(CDate(z.Cells(c, 2).Value))
If Not aa.exists(ae) Then aa.Add ae, True
End If
Next c
d = b + 1: ac = Array("Tax Hold", "Auto Audit", "VAULT", "Duplicate Audit")
For Each y In ThisWorkbook.Sheets
af = y.Name
If IsError(Application.Match(af, ac, 0)) Then
If IsDate(af) Then
On Error Resume Next: ag = CLng(CDate(Replace(af, "-", "/"))): On Error GoTo 0
ah = False: ai = aa.Keys
For e = 0 To aa.Count - 1
If Right(ai(e), Len(ag)) = CStr(ag) Then ah = True: Exit For
Next e
If Not ah Then
With y
f = .Cells(.Rows.Count, 2).End(xlUp).Row
If f >= 2 Then
ad = .Range("B2:B" & f).Value
For g = 1 To UBound(ad, 1)
If Trim(ad(g, 1)) <> "" Then
ae = Trim(ad(g, 1)) & "|" & ag
If Not aa.exists(ae) Then
z.Cells(d, 1).Value = Trim(ad(g, 1))
z.Cells(d, 2).Value = CDate(Replace(af, "-", "/"))
aa.Add ae, True: d = d + 1
End If
End If
Next g
End If
End With
End If
End If
End If
Next y
Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

 

[Georgiboy]

Hi Teffi,

I added a worksheet named 'Lookup' to track previously copied sheets and prevent duplicate data. You'll need to add this sheet manually (it can be blank).

The code loops through sheets in reverse, assuming the newest is on the left and the oldest on the right, so older data appears first in the copied list.

It doesn’t run automatically - you’ll need to execute it when adding a new sheet. Also, unprotect the 'Duplicate Audit' sheet before running. While I could add an unprotect step in the code, it would require storing the password in the code, which may not be ideal.

Sub GatherData()
    Dim wsDA As Worksheet, wsLU As Worksheet, ws As Worksheet
    Dim rngLU As Range, rngC As Range
    Dim x As Long
  
    Set wsDA = Sheets("Duplicate Audit")
    Set wsLU = Sheets("Lookup")
    Set rngLU = wsLU.Range("A:A")
  
    For x = Sheets.Count To 1 Step -1
        Set ws = Sheets(x)
        If IsNumeric(Replace(ws.Name, "-", "")) And Application.CountIf(rngLU, ws.Name) < 1 Then
            Set rngC = ws.Range("B2", ws.Cells(Rows.Count, "B").End(xlUp))
            If Not rngC Is Nothing Then
                wsDA.Cells(Rows.Count, "B").End(xlUp).Offset(1).Resize(rngC.Rows.Count) = rngC.Value
                wsLU.Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = ws.Name
            End If
        End If
    Next x
End Sub

 

[Sam_D_Ben]

Slightly updated,

Sub Teffi()
Dim a$, b&, c&, d&, e&, f&, g&, h&, i&, j&, k&, l&, m&, n&, o&, p&, q&, r&, s&, t&, u&, v&, w&, x&
Dim y As Worksheet, z As Worksheet, aa As Object, ab As Range, ac As Variant, ad As Variant
Dim ae$, af$, ag$, ah As Boolean, ai As Variant
Application.ScreenUpdating = False: Application.EnableEvents = False
Set z = ThisWorkbook.Sheets("Duplicate Audit")
If z.ProtectContents Then MsgBox "?Please unprotect the 'Duplicate Audit' sheet", _
vbExclamation, "Sheet Protected": Exit Sub
Set aa = CreateObject("Scripting.Dictionary")
b = z.Cells(z.Rows.Count, 1).End(xlUp).Row
If z.Cells(1, 1).Value = "" Then z.Cells(1, 1).Value = "UNIT": z.Cells(1, 2).Value = "DATE": b = 1
For c = 2 To b
If IsDate(z.Cells(c, 2).Value) Then
ae = Trim(z.Cells(c, 1).Value) & "|" & CLng(CDate(z.Cells(c, 2).Value))
If Not aa.exists(ae) Then aa.Add ae, True
End If
Next c
d = b + 1: ac = Array("Tax Hold", "Auto Audit", "VAULT", "Duplicate Audit")
For Each y In ThisWorkbook.Sheets
af = y.Name
If IsError(Application.Match(af, ac, 0)) Then
If IsDate(af) Then
On Error Resume Next: ag = CLng(CDate(Replace(af, "-", "/"))): On Error GoTo 0
ah = False: ai = aa.Keys
For e = 0 To aa.Count - 1
If Right(ai(e), Len(ag)) = CStr(ag) Then ah = True: Exit For
Next e
If Not ah Then
With y
f = Application.Max(.Range("B:B").Find("*", , xlValues, , , xlPrevious).Row, 2)
'f = .Cells(.Rows.Count, 2).End(xlUp).Row
If f >= 2 Then
ad = .Range("B2:B" & f).Value
For g = 1 To UBound(ad, 1)
If Trim(ad(g, 1)) <> "" Then
ae = Trim(ad(g, 1)) & "|" & ag
If Not aa.exists(ae) Then
z.Cells(d, 1).Value = Trim(ad(g, 1))
z.Cells(d, 2).Value = CDate(Replace(af, "-", "/"))
aa.Add ae, True: d = d + 1
End If
End If
Next g
End If
End With
End If
End If
End If
Next y
Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

 

[Sam_D_Ben]

Or this,

Sub Teffi()
Dim a$, b&, c&, d&, e&, f&, g&, y As Worksheet, z As Worksheet, aa As Object, ac, ad, ae$, af$, ag$
Application.ScreenUpdating = False: Application.EnableEvents = False
Set z = Sheets("Duplicate Audit")
If z.ProtectContents Then MsgBox "? Please unprotect the 'Duplicate Audit' sheet", _
vbExclamation, "Sheet Protected": Exit Sub
Set aa = CreateObject("Scripting.Dictionary")
b = z.Cells(z.Rows.Count, 1).End(xlUp).Row
If z.Cells(1, 1).Value = "" Then z.Cells(1, 1).Value = "UNIT": _
z.Cells(1, 2).Value = "DATE": b = 1
For c = 2 To b
If IsDate(z.Cells(c, 2).Value) Then
ae = Trim(z.Cells(c, 1).Value) & "|" & CLng(CDate(z.Cells(c, 2).Value))
If Not aa.exists(ae) Then aa.Add ae, True
End If
Next c
d = b + 1: ac = Array("Tax Hold", "Auto Audit", "VAULT", "Duplicate Audit")
For Each y In Sheets
af = y.Name
If IsError(Application.Match(af, ac, 0)) Then
If IsDate(af) Then
On Error Resume Next: ag = CLng(CDate(Replace(af, "-", "/"))): On Error GoTo 0
With y
On Error Resume Next
f = Application.Max(.Range("B:B").Find("*", , xlValues, , , xlPrevious).Row, 2)
On Error GoTo 0
If f >= 2 Then
ad = .Range("B2:B" & f).Value
For g = 1 To UBound(ad, 1)
If Trim(ad(g, 1)) <> "" Then
ae = Trim(ad(g, 1)) & "|" & ag
If Not aa.exists(ae) Then
z.Cells(d, 1).Value = Trim(ad(g, 1))
z.Cells(d, 2).Value = CDate(Replace(af, "-", "/"))
d = d + 1
End If
End If
Next g
End If
End With
End If
End If
Next y
Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub