I am working on a solution to copy data from several Sheets to a single sheet and append it to the last row of an existing table. I have the code working except when the data is copied to the bottom of the srcWs it does not take the form of the current table. I am using UsedRange because there are gaps in the data from the actShtNames that could amount to several blank Rows being copied.
Dim srcWB As Workbook
Dim srcWs As Worksheet
Dim shtCount As Integer
Dim actShtName As String
Dim lRow As Long
Dim cEndRow As Long
Dim txt As Range
Dim tbl As ListObject
'Set the SCR workbook and worksheet
Set srcWB = Workbooks.Open("\\***")
MsgBox (srcWB.Name)
Set srcWs = srcWB.Worksheets("R_Data")
srcWs.Activate
'Get the current last row of the table of the srcWs
cEndRow = Range("A" & Rows.Count).End(xlUp).Row
'MsgBox (cEndRow)
Set tbl = srcWs.ListObjects("Table1")
'For sheets that start at index after sheets 1-5 to end of workbook.
For shtCount = Worksheets("1-5").Index + 1 To Worksheets.Count
Sheets(shtCount).Activate
actShtName = ActiveSheet.Name
If actShtName = "R_Data" Or actShtName = "Warehouse_Data" Or actShtName = "Sheet2" Then
'If Sheet is R Data then ignore the sheet. That is the src worksheet that houses data
'Also ignore Warehouse data and sheet2
Else
'MsgBox (actShtName)
If Worksheets(actShtName).UsedRange.Count > 1 Then
lRow = srcWs.Range("A" & Rows.Count).End(xlUp).Row
'MsgBox (lRow)
With Worksheets(actShtName).UsedRange
srcWs.Cells(lRow + 1, 1).Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With
End If
End If
Next shtCount
'Delete any duplicate headrs that are copied over
For Each txt In srcWs.Range("A2:A" & lRow)
If txt.Value = "Supply Name" Then
txt.EntireRow.Delete
End If
Next txt
Bookmarks