如果第一行/标题中的某个单元格相同，则剪切多列

Question

我目前是宏VBA的新手，如果特定行的值相同，我一直在尝试复制一列，然后将其粘贴到另一张纸上，直到复制并粘贴所有列。这样做的目的是巩固团队的团队成员（团队就是我试图寻找的价值）。仅当右边的下一个单元格已为空白时，它才会停止。而且我只会在表格的第一行中找到团队成员的团队。我放置了我在Internet上找到的代码并对其进行了修改，但它仅复制它找到的最后一个DATA团队。谢谢。

Dim ws As Worksheet
Dim aCell As Range, Rng As Range
Dim col As Long, lRow As Long
Dim colName As String

Set ws = ThisWorkbook.Sheets("Values")

With ws
    Set aCell = .Range("A1:XFD1").Find(What:="DATA", LookIn:=xlValues, LookAt:=xlWhole, _
                MatchCase:=False, SearchFormat:=False)

If Not aCell Is Nothing Then

aCell.EntireColumn.Cut

Sheets("Team").Columns("D:W").Insert Shift:=xlToRight

Else
MsgBox "Team not found"

End If
End With

Answer 1

您可以尝试一下。

Option Explicit

Sub CopyCols()

    Dim ArrTeams() As String, Team As String
    Dim TeamCounter As Long, LastCol As Long, FirstCol As Long, i As Long, LastColDest As Long
    Dim SrcWs As Worksheet
    Dim Wb As Workbook

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set Wb = ThisWorkbook
    Set SrcWs = Wb.Sheets("Sheet1")
    ReDim ArrTeams(1 To 1)
    With Wb        
        With SrcWs
            'find last column with team
            LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            TeamCounter = 1
            FirstCol = 1 'or whatever your first column with teams is

            'loop all columns in row 1
            For i = FirstCol To LastCol
                If .Cells(1, i) <> "" Then
                    Team = .Cells(1, i)
                    If Not IsInArray(Team, ArrTeams) Then 'take only unique team names
                        ReDim Preserve ArrTeams(1 To TeamCounter)
                        ArrTeams(TeamCounter) = Team
                        TeamCounter = TeamCounter + 1
                    End If
                End If
            Next i
        End With

        'create new sheet for each team
        For i = 1 To UBound(ArrTeams)
            .Sheets.Add after:=.Sheets(.Sheets.Count)
            .Sheets.Item(.Sheets.Count).Name = ArrTeams(i)
        Next i

         With SrcWs
            'loop all columns in row 1
            For i = FirstCol To LastCol
                If .Cells(1, i) <> "" Then
                    Team = .Cells(1, i)
                    With Wb.Sheets(Team)
                        'find last non empty column on destination sheet
                        LastColDest = .Cells(1, .Columns.Count).End(xlToLeft).Column
                    End With
                    .Cells(1, i).EntireColumn.Copy
                    Wb.Sheets(Team).Cells(1, LastColDest + 1).PasteSpecial
                End If
            Next i
        End With
    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean

  IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))

End Function

它应该循环"Sheet1"上的所有列，从FirstCol到LastCol结束，并从第一行获取唯一的团队名称。为每个唯一的团队名称创建一个新表。将每个唯一团队名称的整个列复制到对应的工作表中。
请记住，它将始终添加新的工作表，因此，如果要多次运行它，则应检查是否存在具有特定名称的工作表。

编辑

添加
Dim LastRow As Long, j As Long
还有
Dim TargetWs As Worksheet
在开始的声明部分
更改用于向

添加新工作表的循环

For i = 1 To UBound(ArrTeams)
    .Sheets.Add after:=.Sheets(.Sheets.Count)
    .Sheets.Item(.Sheets.Count).Name = ArrTeams(i)
    .Sheets(ArrTeams(i)).Range("A2:A1000").FormulaR1C1 = _ 
    "=SUM(RC[2]:RC[" & .Sheets(ArrTeams(i)).Columns.Count - 1 & "])"
Next i 

最后添加

For i = LBound(ArrTeams) To UBound(ArrTeams)
    Team = ArrTeams(i) 'team name and also sheet name
    Set TargetWs = .Sheets(Team)
    With TargetWs
        .Calculate 'calculate SUM formula on each sheet 
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in column "A"
        For j = LastRow To 2 Step -1 'assuming that in row 1 there is some header
            If .Cells(j, "A") = 0 Then
                .Cells(j, "A").EntireRow.Delete
            End If
        Next j
    End With
Next i

只要您的数据行不超过1000行，就可以实现此目的。如果是这样，您可以调整SUM公式以覆盖更多行，或者在每个“团队”表上查找包含数据的最后一行，然后循环调整公式。

Answer 2

嗨，@ Sphinx，这就是我到目前为止所拥有的。我修改了您提供的代码，并在其中添加了一些内容。我没有的语法是关于当列C上的特定单元格具有0值时如何删除行的语法。而且它仅适用于所有ArrTeams（i）工作表。谢谢您的帮助。

https://i.stack.imgur.com/M8NS8.png

Option Explicit

Sub CopyCols()

Dim ArrTeams() As String, Team As String
Dim TeamCounter As Long, LastCol As Long, FirstCol As Long, i As Long, LastColDest As Long
Dim SrcWs As Worksheet
Dim Wb As Workbook
Dim LastRowColumnD As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set Wb = ThisWorkbook
Set SrcWs = Wb.Sheets("Values")
ReDim ArrTeams(1 To 1)
With Wb
    With SrcWs
        'find last column with team
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        TeamCounter = 1
        FirstCol = 1 'or whatever your first column with teams is

        'loop all columns in row 1
        For i = FirstCol To LastCol
            If .Cells(1, i) <> "" Then
                Team = .Cells(1, i)
                If Not IsInArray(Team, ArrTeams) Then 'take only unique team names
                    ReDim Preserve ArrTeams(1 To TeamCounter)
                    ArrTeams(TeamCounter) = Team
                    TeamCounter = TeamCounter + 1
                End If
            End If
        Next i
    End With

    'create new sheet for each team
    For i = 1 To UBound(ArrTeams)
        .Sheets.Add After:=.Sheets(.Sheets.Count)
        .Sheets.Item(.Sheets.Count).Name = ArrTeams(i)
        Sheets("Values").Columns("A:C").Copy
        ActiveSheet.Paste Destination:=Worksheets(ArrTeams(i)).Range("A1:C1")
Range("A1").Value = " "
Range("B1").Value = " "
Range("C1").Value = " "
Range("A2").Value = "Team:"
Range("B2").Value = ArrTeams(i)
Range("C2").Value = " "
Range("B2").HorizontalAlignment = xlCenter
Range("B2").VerticalAlignment = xlCenter
Range("A2").HorizontalAlignment = xlCenter
Range("A2").VerticalAlignment = xlCenter
LastRowColumnD = Cells(Rows.Count, 1).End(xlUp).Row
Range("C4:C" & LastRowColumnD).Formula = "=sum(D4:XFD4)"


    Next i

     With SrcWs
        'loop all columns in row 1
        For i = FirstCol To LastCol
            If .Cells(1, i) <> "" Then
                Team = .Cells(1, i)
                With Wb.Sheets(Team)
                    'find last non empty column on destination sheet
                    LastColDest = .Cells(1, .Columns.Count).End(xlToLeft).Column
                End With
                .Cells(1, i).EntireColumn.Copy
                Wb.Sheets(Team).Cells(1, LastColDest + 1).PasteSpecial
            End If
        Next i
    End With
End With




Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean

IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))

End Function