Question: The code that Variatus wrote is working up to the point where it gives the err message block for each of the worksheet tabs, but I still need assistance on getting the data copied to the appropriate tables (24 of them) that are located in the MONTHLY GOE RECONCILIATION worksheet (Attached).
For the worksheets 21000, 21010, 21020, 21030, 21036, 21070 and 21090 listed on the Sheetlists, column "K" (11) is where the "NO" is selected, that will then trigger the copying of data from columns B, D, and J on the row where "NO" was selected and paste that data into the appropriate table by same name and put the data into columns B, C and D on first available row.
For all the other worksheets listed in the Sheetlist, Column "I" (9) is where the "NO" is selected from the dropdown list that will cause the data from columns A, B and G to be copied into the appropriate table in the MONTHLY GOE RECONCILIATION worksheet (attached) under columns B, C and D on first available row.
One thought is I need to modify the sheetlist that has dropdown list in column "K" and then insert another set of code for those sheetlist items with dropdown in column G. Then modify the CopyToTable portion of code for the SheetList items where the dropdown is located in column "K". Just a possible idea but not sure.
I appreciate any help to get this code to work, as it is the final phase of this project.
Option Explicit
Private Sub TestLoop()
Dim Ws As Worksheet
Dim SheetList As String
Application.ScreenUpdating = False
For Each Ws In Worksheets
' list all your 23 sheets in this string"
SheetList = "21000 State Program Travel,21010 Miscellaneous Travel,21020 Presentation Travel,21030 Conference Travel,21036 Training Travel,21070 Shared or Remote Travel,"
SheetList = SheetList & "21090 Division Retreat Travel,21071 GOV Related Costs,23230 Conference Room Rental,23370 Telephone Services,24090 Printing and Reproduction,"
SheetList = SheetList & "24120 Subscriptions Periodicals,25103 Professional Fees,25108 Registration Fees,25209 Room Rental Retreat Svcs,"
SheetList = SheetList & "25215 Other Goods & Services,25338 Fingerprints,25626 Wellness,25713 Copiers Recurring Costs,26062 Supplies,26069 Safety Equipment,"
SheetList = SheetList & "31050 Equipment ADP NONCAP,31110 Office Equipment,31300 Software"
If InStr(1, SheetList, Ws.Name, vbTextCompare) Then
CopyToTable Ws
End If
Next Ws
Application.ScreenUpdating = True
End Sub
Private Sub CopyToTable(Ws As Worksheet)
' 02 Dec 2017
Dim Tbl As ListObject
Dim NewRow As ListRow
Dim RowArray As Variant
Dim Rl As Long
Dim R As Long, C As Long
On Error Resume Next
Set Tbl = Ws.ListObjects(Ws.Name)
If Err Then
MsgBox "Please set up a table by the name of" & vbCr & _
"""" & Ws.Name & """ and run this macro again.", _
vbExclamation, "Missing table"
Else
Tbl.DataBodyRange.Rows.Delete ' delete all table content
End If
On Error GoTo 0
' make sure that your table is NOT in column A
' or select another column to determine the last used row in the sheet
Rl = Ws.Cells(Ws.Rows.Count, "A").End(xlUp).Row
For R = 6 To Rl ' start looking in row 6
With Ws.Rows(R)
' 9 = Column I
If StrComp(.Cells(9).Value, "no", vbTextCompare) = 0 Then
' column 7 = G
RowArray = Range(.Cells(1), .Cells(7)).Value
' move value of column 7 to column 3
RowArray(1, 3) = RowArray(1, 7)
' discard columns 4 to 7
ReDim Preserve RowArray(1 To 1, 1 To 3)
With Tbl
Set NewRow = .ListRows.Add
.DataBodyRange.Cells(.ListRows.Count, 1).Resize(1, UBound(RowArray, 2)).Value = RowArray
End With
End If
End With
Next R
End Sub