как скопировать только первые 4 столбца в цикле

Question

Я пытаюсь скопировать из электронной таблицы в другую, используя несколько частей кода, найденного здесь, однако после внесения некоторых изменений я сталкиваюсь с проблемой, когда после копирования значений из sheet1 в sheet2 происходит копированиевсе 2000 столбцов, когда мне просто нужно скопировать первые 4 столбца, также мне нужно скопировать все в ('TC1')

, обратите внимание, что TC1 будет перечисляться 3 раза на каждом листе.

1) В резюме я хочу просто скопировать первые 4 столбца 2) между концом TC1 и следующим, указанным в столбце (1) есть 2 или более пробелов, 3) это просто копирование первых несколькихстроки вместо всего списка до Lastrow достигают TC1

    'VBA Open excel to copy TC to master list Dir
Sub Copy_Paste__To_New_Sheet()

    'Variable Declaration
    Dim sFilePath As String
    Dim sFileName As String
    Dim wb As Excel.Workbook
    Dim rngCopy As Range, acell As Range, bcell As Range
    Dim strSearch As String
    Dim strFile As Variant
    Dim wb2 As Excel.Workbook


    'Specify File Path
    sFilePath = "C:\temp\new"

    'Check for back slash
    If Right(sFilePath, 1) <> "\" Then
        sFilePath = sFilePath & "\"
    End If

    sFileName = Dir(sFilePath)

    Do While Len(sFileName) > 0
    Set rngCopy = Nothing
    Application.DisplayAlerts = False
    Set wb = Workbooks.Open(Filename:=sFilePath & sFileName)
        Sheets("TestCases").Activate
'        Range("E:E").Insert
        'Display file name in immediate window
'        Debug.Print sFileName
        strSearch = "TC1"

    Set WS = Worksheets("TestCases")

    With WS
        Set acell = .Columns(1).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        If Not acell Is Nothing Then
            Set bcell = acell

            If rngCopy Is Nothing Then
                Set rngCopy = WS.Range(WS.Cells(acell.Row + 1, 1), WS.Cells(acell.Row + 2, 4))
            Else
                Set rngCopy = Application.Union(rngCopy, .Rows((acell.Row + 1) & ":" & (acell.Row + 2)))
            End If

            Do
                Set acell = .Columns(1).FindNext(After:=acell)

                If Not acell Is Nothing Then
                    If acell.Address = bcell.Address Then Exit Do

                    If rngCopy Is Nothing Then
                        Set rngCopy = WS.Range(WS.Cells(acell.Row + 1, 1), WS.Cells(acell.Row + 2, 4))
                    Else
                        Set rngCopy = Application.Union(rngCopy, .Rows((acell.Row + 1) & ":" & (acell.Row + 2)))
                    End If
                Else
                    Exit Do
                End If
            Loop
        Else
            MsgBox SearchString & " not Found"
        End If

        '~~> I am pasting to Output sheet. Change as applicable

            Set wb2 = Workbooks.Open("C:\temp\output\outputtest.xlsx")
            If Not rngCopy Is Nothing Then Sheets("Output").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(rngCopy.Rows.Count, 4).Value = rngCopy.Value

'            If Not rngCopy Is Nothing Then Sheets("Output").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 4).Value = rngCopy.Value
'        If Not rngCopy Is Nothing Then rngCopy.Copy Sheets("Output").Cells(1, 1).Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
'        .End (xlDown) + 1
'        Sheets("Output").Rows(1)
        Application.DisplayAlerts = False
        wb2.Close savechanges = False

    End With

Answer 1

Вы установили rngCopy на всю строку каждый раз. Это означает, что он скопирует все столбцы этой строки. Вместо этого вам нужно установить rngCopy, чтобы включить только первые 4 столбца. Вы можете сделать это с чем-то вроде этого

Set rngCopy = WS.Range(WS.Cells(acell.Row + 1, 1), WS.Cells(acell.Row + 2, 4))

вместо

Set rngCopy = .Rows((acell.Row + 1) & ":" & (acell.Row + 2))