Selected Answer
Please paste the code below in a standard code module (by default 'Module1' but you can give it any name). Observe that both subs are 'Private', meaning you can't call them from the worksheet. Depending upon how you wish to initialise the action you may remove the 'Private' from the first sub, but not from the second. It will still work if you do, but it can't work when called from the worksheet. So, why make it available?
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 = "CaptRet,Capt2,Capt3,Capt4" & _
"Ret1,Ret2,Ret3" & _
"Some,Other,Sheet's,Name"
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
The first sub loops through all the sheets in your workbook, compares each sheet's name against an "approved" list and ignores those which aren't on the list. Perhaps it's shorter to make a list of the sheets not to process If you make such a list change the line below the list to read "If InStr(1, SheetList, Ws.Name, vbTextCompare) = 0 Then" (adding "= 0").
The rest of the code is pretty straight forward. I have added some comments for you which I hope will help you understand the logic. I felt, however, that your method of entering "Yes" and "No" is cumbersome, especially if you are facing co-workers who like to delete things. I have designed code which runs when you double-click on a cell. Each time you double-click the cell value will toggle between "Yes" and "No". The program limits this action to the sells in column I. To try it out, please install the function below in a standard code module. You can add it to the other code. Observe that this procedure must be 'Public" which it is by default, if not declared as "Private".
Function DoubleClick(ByVal Target As Range)
' 02 Dec 2017
Dim Ws As Worksheet
Dim Rng As Range
Dim Rl As Long
DoubleClick = False
With Target
Set Target = .Cells(1)
Set Ws = .Worksheet
End With
With Ws
' make sure that your table is NOT in column A
' or select another column to determine the last used row in the sheet
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = Range(.Cells(6, "I"), .Cells(Rl, "I"))
End With
If Not Application.Intersect(Target, Rng) Is Nothing Then
With Target
.Value = Array("No", "Yes")(Abs(Sgn(StrComp(.Value, "Yes", vbTextCompare))))
End With
DoubleClick = True
End If
End Function
This function responds to an event procedure. Event procedures are 'Private' to each worksheet. They must be installed in the code sheet of the worksheet on which you want to have the action. It is very short code, but you must install it on each of your 23 sheets.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = DoubleClick(Target)
End Sub