时间戳

首页 > 解决方案 > 如何在循环中仅复制前 4 列

excel - 如何在循环中仅复制前 4 列

问题描述

我正在尝试使用此处找到的代码的几部分从电子表格复制到另一个电子表格，但是在进行一些调整后，我遇到了一个问题，在将值从其中复制sheet1到它之后sheet2，当我只需要它时复制所有 2000 列复制前 4 列，我还需要复制 ('TC1') 下的所有内容

请注意，TC1 将在每个工作表上列出 3 次。

1) 我在简历中的意思是我只想复制前 4 列 2) TC1 的末尾和列 (1) 中列出的下一个之间有 2 个或更多空格 3) 它只是复制前几行而不是到达 TC1 的 Lastrow 之前的整个列表

    '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

源数据 目的地

标签： excelvba

解决方案

您每次都设置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))

推荐阅读