VBA for Excel - 按条件复制数据 -

Question

我有一个表格，其中的数据按 1 到 10 组排列。每个组有一行或多行。 我只想从每个组的第一行复制数据并将其粘贴到另一张纸上。 实现这一目标的正确方法是什么？ 到目前为止，我所有创建带有条件的循环的尝试都没有成功。 提前高度感谢任何帮助或推动正确方向。

Sub GenerateReport()

Dim RowCountCopy As Integer
Dim RowCountPaste As Integer

RowCountCopy = 2
RowCountPaste = 3
 
    For i = 1 To 10

        Sheets("Sheet2").Range("A" & RowCountPaste) = Sheets("Sheet1").Range("A" & RowCountCopy)
        Sheets("Sheet2").Range("B" & RowCountPaste) = Sheets("Sheet1").Range("B" & RowCountCopy)
        Sheets("Sheet2").Range("C" & RowCountPaste) = Sheets("Sheet1").Range("F" & RowCountCopy)
    
        RowCountCopy = RowCountCopy + 1
        RowCountPaste = RowCountPaste + 1
 
 
    Next i
 
End Sub

这是在没有任何条件循环的情况下生成代码的原因。

这就是我想要达到的目标。

Answer 1

因为您正在使用表格，所以这是我的方法。 代码有一些cmets，但必要时一步步调试以便更好理解。

Sub copyFirstRowOfEachGroup()
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim ol As ListObject: Set ol = ws.ListObjects(1)
    Dim olColOrder As ListColumn, olColRank As ListColumn
    Dim olColRng As Range
    
    On Error GoTo errhandler
    
    ' Add temporary columns: Order & Rank
    Set olColOrder = ol.ListColumns.Add: olColOrder.Name = "Order"
    Set olColRank = ol.ListColumns.Add: olColRank.Name = "Rank"
    
    ' create an order depending on the ROW
    Set olColRng = olColOrder.DataBodyRange
    olColRng.FormulaR1C1 = "=[@Group]+ROW(R[1]C[1])/100000"
    
    ' set the rank in each goup
    Set olColRng = olColRank.DataBodyRange
    olColRng.FormulaR1C1 = "=COUNTIFS([Group],[@Group],[Order],""<""&[@Order])+1"
    
    ' set advanced filter criteria
    ws.Range("M1").Value = "Rank"
    ws.Range("M2").Value = 1
    Dim crtRng As Range: Set crtRng = ws.Range("M1:M2")
    
    ' set destination range
    ws.Range("G1").Value = "ID"
    ws.Range("H1").Value = "Name"
    ws.Range("I1").Value = "Group"
    Dim dstRng As Range: Set dstRng = ws.Range("G1:I1")
    
    ' advanced filter
    ol.Range.AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=crtRng, _
        CopyToRange:=dstRng, _
        Unique:=False

    ' delete temporay columns and advanced filter criteria
    crtRng.ClearContents
    olColOrder.Delete
    olColRank.Delete
    
errRoutine:
    ' clean
    Set crtRng = Nothing
    
    Exit Sub

errhandler:
    Debug.Print Err.Number, Err.Description
    Resume errRoutine
End Sub

这是我的文件：https://www.dropbox.com/s/r42riiylcss5j7w/CopyWithCriteria.xlsm?dl=0

Answer 2

请尝试下一个代码：

Sub returnGropFirsRow()
 Dim sh1 As Worksheet, sh2 As Worksheet, lastR1 As Long, arr, arrFin, i As Long, k As Long
 
 Set sh1 = Worksheets("Sheet1")
 Set sh2 = Worksheets("Sheet2")
 astR1 = sh1.Range("A" & sh1.rows.count).End(xlUp).row 'last row in sh1
 arr = sh1.Range("A1:F" & lastR1).value                         'put the range in an array to make the code faster
 
 ReDim arrFin(1 To 3, 1 To UBound(arr) + 1): k = 1               'redim the final array to have place for all possible cases
 
 arrFin(1, k) = "ID": arrFin(2, k) = "Name": arrFin(3, k) = "Group" 'put the header in the final array
 For i = 2 To UBound(arr)                                           'iterate between the arr elements
    If arr(i, 6) <> arr(i - 1, 6) Then                              'if arr element not equal with the one above it:
        k = k + 1                                                   'increment k (future row) variable
        arrFin(1, k) = arr(i, 1): arrFin(2, k) = arr(i, 2): arrFin(3, k) = arr(i, 6) 'load the necessary elements in the final array
    End If
 Next i
 
 ReDim Preserve arrFin(1 To 3, 1 To k)      'redim final array in order to keep only the filled values
  'drop the array content at once and format the range:
 Dim arrBord, El
 arrBord = Application.Evaluate("Row(7:12)")
 With sh2.Range("A1").Resize(UBound(arrFin, 2), UBound(arrFin))
    .value = Application.Transpose(arrFin)
    .EntireColumn.AutoFit
    For Each El In arrBord
        With .Borders(El)
          .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = 0
        End With
    Next El
    .BorderAround , xlMedium
    With .Range(.cells(1, 1), .cells(1, 3))
        .Font.Bold = True
        .BorderAround , xlMedium
        .Interior.ColorIndex = 20
        .HorizontalAlignment = xlCenter
    End With
 End With
End Sub