copy a string from sheets if another string was found-CodePudding

I have a workbook with multiple sheets and data in both column A and B only.

I am trying to do the following:

Search for the string TH in column A in all sheets and if found in one sheet then copy the data offset to EN from column B (EN has a fixed location A2 ), create a new sheet named TH and paste copied data in the first cell then paste the next data from another sheet in the second cell and so on.

I don't really know anything about VBA with that in mind I scavenged the following code from multiple sources.

Sub CopyData()

    Dim I As Integer
    Dim Cell As Range
    Dim RowCNT As Integer
    Dim Exists As Boolean

    RowCNT = 1

    For I = 1 To ActiveWorkbook.Worksheets.Count
        For Each Cell In Worksheets(I).Range("A1:A" & Worksheets(I).Cells(Worksheets(I).Rows.Count, "A").End(xlUp).Row)
            pos = InStr(Cell.Value, "TH")
            If pos > 0 Then
                For n = 1 To ActiveWorkbook.Worksheets.Count
                   If Worksheets(n).Name = "TH" Then
                      Exists = True
                   End If
                Next n
                If Not Exists Then
                   Worksheets.Add.Name = "TH"
                End If
                   Sheets("TH").Cells(RowCNT, 1).Value = Worksheets(I).Range("B2").Value
                   RowCNT = RowCNT   1
            End If
        Next Cell
    Next I

End Sub

The result I got can be found in the following image

The data I have is bigger than the examples, and the following happens:

If I run the VBA code once and the sheet TH isn't created while the first sheet is the active sheet:

The sheet is created, and the data is pasted starting from A2 not A1
The last value/entry isn't pasted and missing
After that If I run the VBA code again the data is pasted again but this time starting from A1 and the last entry is pasted as well.

If I run the VBA code once and the sheet TH isn't created, while any sheet other than the first one is the active sheet:

The sheet is created, and the data is pasted starting from A1
The last value/entry isn't pasted and missing
After that If I run the VBA code again the data is pasted again but this time starting from A1 and the last entry is pasted as well.

If I run the VBA code once and the sheet TH is already created:

Everything works as wanted, data is pasted starting from cell A1 and last entry is present as well from a single code run.

So I was wondering if someone can point out the problems in this code and tell me if there are any unnecessary methods or better ways to accomplish this. And it would be better if it was edits to the existing code and not something from scratch (This way I might learn something) :).

CodePudding user response：

Option Explicit

Sub test1()
    Dim TH As Worksheet, ws As Worksheet, m
    Dim pnt As Long: pnt = 1
    
    With ActiveWorkbook ' or ThisWorkbook
        ' prepare TH sheet
        On Error Resume Next
        Set TH = .Worksheets("TH")
        On Error GoTo 0
        If TH Is Nothing Then ' if TH not exists, create it
            Set TH = .Worksheets.Add
            TH.Name = "TH"
        Else 'if TH exists, clear it
            TH.Cells.Delete
        End If
            
        For Each ws In .Worksheets 'loop over all the sheets in the WB
            If ws.Name <> TH.Name Then ' skip TH sheet
                m = Application.Match(Array("TH", "EN"), ws.Columns("A"), 0) ' returns array(1..N) with row numbers (if values was found) or errors (if values was not found)
                If IsNumeric(m(1)) And IsNumeric(m(2)) Then
                    TH.Cells(pnt, "A") = ws.Cells(m(2), "A").Offset(, 1) 'if the "keys" TH and EN are found, get the value from the cell with the specified offset and write to TH sheet
                    pnt = pnt   1 ' increment pointer to next row in the TH sheet
                End If
            End If
        Next
    End With
End Sub