CODEWITHSUNDEEP
excelvbacopyconditional-statements
nikolayDudrenov
nikolayDudrenov

Reputation: 169

VBA for Excel - copy Data by criteria -

I have a table with data arranged in groups from 1 to 10. Each group have one or more rows. I want to copy data only from the first row of each group and paste it to another sheet. What is the correct approach to achieve this? So far, all my attempts to create a loop with condition were unsuccessful. Any help or push in the right direction is highly appreciated in advance.

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

Initial Data

This is what generate the code without any conditions loops.

Report when I run my code

This is what I want to achieve.

Desired report

Upvotes: 0

Views: 198

Answers (2)

Elio Fernandes
Elio Fernandes

Reputation: 1420

Because you are working with tables, here is my approach. The code has some comments, but debug step by step to better understand if necessary.

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

Here is my file: https://www.dropbox.com/s/r42riiylcss5j7w/CopyWithCriteria.xlsm?dl=0

Upvotes: 0

FaneDuru
FaneDuru

Reputation: 42236

Please, try the next code:

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

Upvotes: 1

Related Questions