We help IT Professionals succeed at work.

Loop Data

Cartillo
Cartillo asked
on
Hi Experts,

I would like to request Experts help to add additional function in the attached script. The macro able to copy data from Data sheet to Detail Sheet. Each time run the macro, the new data will override the old data. Is that possible to copy new data from "Data" sheet to "Detail" at new row instead of overriding the old data? Hope Experts will help me to add this new feature.    
Sub Filter()
    
    Dim k(), ka, I As Long, d As String, n As Long, c As Long
    
    With Worksheets("Data")
        ka = .Range("a6:d" & .Range("a" & .Rows.Count).End(xlUp).Row)
    End With
    
    ReDim k(1 To UBound(ka, 1), 1 To 5)
    
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        
        .Add "Type 1", Nothing
        .Add "Type 3", Nothing
        
        For I = 1 To UBound(ka, 1)
            If IsDate(ka(I, 1)) Then d = ka(I, 1): GoTo Nxt ' Like "*(*)" Then
            If Len(ka(I, 3)) Then
                If .exists(ka(I, 2)) Then
                    If Not .exists(ka(I, 3)) Then
                        n = n + 1: k(n, 1) = d
                        For c = 1 To UBound(ka, 2)
                            k(n, c + 1) = ka(I, c)
                        Next
                        .Add ka(I, 3), Nothing
                    End If
                End If
            End If
Nxt:
        Next
    End With
    If n Then
        With Worksheets("Detail")
            .UsedRange.Offset(1).ClearContents
            Union(.Range("b2").Resize(n), .Range("e2").Resize(n)).NumberFormat = "[h]:mm"
            .Range("a2").Resize(n, UBound(k, 2)) = k
        End With
    End If
    
End Sub

Open in new window

Data-Copy.xls
Comment
Watch Question

Commented:
Sure, that shouldn't be an issue. I'm not sure exactly where you want the data put, but using the example you provided, when you open the Detail tab, the data ends in row 22.  The following code will add the new data to row 24 without changing anything above. Is that kind of what you were looking for?

Sub Filter()
    
    Dim k(), ka, I As Long, d As String, n As Long, c As Long
    
    With Worksheets("Data")
        ka = .Range("a6:d" & .Range("a" & .Rows.Count).End(xlUp).Row)
    End With
    
    ReDim k(1 To UBound(ka, 1), 1 To 5)
    
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        
        .Add "Type 1", Nothing
        .Add "Type 3", Nothing
        
        For I = 1 To UBound(ka, 1)
            If IsDate(ka(I, 1)) Then d = ka(I, 1): GoTo Nxt ' Like "*(*)" Then
            If Len(ka(I, 3)) Then
                If .exists(ka(I, 2)) Then
                    If Not .exists(ka(I, 3)) Then
                        n = n + 1: k(n, 1) = d
                        For c = 1 To UBound(ka, 2)
                            k(n, c + 1) = ka(I, c)
                        Next
                        .Add ka(I, 3), Nothing
                    End If
                End If
            End If
Nxt:
        Next
    End With
    If n Then
        With Worksheets("Detail")
            Union(.Range("b2").Resize(n), .Range("e2").Resize(n)).NumberFormat = "[h]:mm"
            .Range("a1").End(xlDown).Offset(2).Resize(n, UBound(k, 2)) = k
        End With
    End If
    
End Sub

Open in new window

Author

Commented:
Hi m4trix,

Indeed, this is what I'm looking for but without a blank row. In this sample the data need to be copied at row 23. Let say, the new data copied from row 24 to 53, the next data need to copy at row 54. Hope this is possible.

Author

Commented:
Hi m4trix,

Hope my explanation is clear. Please do let me know if you need more detail.
Commented:
absolutely. easy fix:
Sub Filter()
    
    Dim k(), ka, I As Long, d As String, n As Long, c As Long
    
    With Worksheets("Data")
        ka = .Range("a6:d" & .Range("a" & .Rows.Count).End(xlUp).Row)
    End With
    
    ReDim k(1 To UBound(ka, 1), 1 To 5)
    
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        
        .Add "Type 1", Nothing
        .Add "Type 3", Nothing
        
        For I = 1 To UBound(ka, 1)
            If IsDate(ka(I, 1)) Then d = ka(I, 1): GoTo Nxt ' Like "*(*)" Then
            If Len(ka(I, 3)) Then
                If .exists(ka(I, 2)) Then
                    If Not .exists(ka(I, 3)) Then
                        n = n + 1: k(n, 1) = d
                        For c = 1 To UBound(ka, 2)
                            k(n, c + 1) = ka(I, c)
                        Next
                        .Add ka(I, 3), Nothing
                    End If
                End If
            End If
Nxt:
        Next
    End With
    If n Then
        With Worksheets("Detail")
            Union(.Range("b2").Resize(n), .Range("e2").Resize(n)).NumberFormat = "[h]:mm"
            .Range("a1").End(xlDown).Offset(1).Resize(n, UBound(k, 2)) = k
        End With
    End If
    
End Sub

Open in new window

Author

Commented:
Hi m4trix,

Thanks a lot.

Explore More ContentExplore courses, solutions, and other research materials related to this topic.