how to loop through cells with same value in a column until last cell-CodePudding

I want to loop through a list and fill a template with it in batches of related items but I can't seem to figure out how to do it. I have been able to loop through all the data but not in group of related items.

I have searched online for a solution but everyone is looping through all the rows but not grouped as shown in the sample below.

sample data

SN	DATE	AMOUNT	COURSE
1	date1	amount1	ABC
1	date1	amount1	ABC
1	date1	amount1	ABC
2	date2	amount2	ABC
2	date2	amount2	ABC
3	date3	amount3	ABC
3	date3	amount3	ABC
3	date3	amount3	ABC

The expected output should look like the following:

    <ENTRY>
    <COURSE> ABC </COURSE>
    <Date> date1 </DATE> <AMOUNT> Amount1 </AMOUNT>
    <Date> date1 </DATE> <AMOUNT> Amount1 </AMOUNT>
    <Date> date1 </DATE> <AMOUNT> Amount1 </AMOUNT>
    </ENTRY>
    
    <ENTRY>
    <COURSE> ABC </COURSE>
    <Date> date2 </DATE> <AMOUNT> Amount2 </AMOUNT>
    <Date> date2 </DATE> <AMOUNT> Amount2 </AMOUNT>
    </ENTRY>

    <ENTRY>
    <COURSE> ABC </COURSE>
    <Date> date3 </DATE> <AMOUNT> Amount3 </AMOUNT>
    <Date> date3 </DATE> <AMOUNT> Amount3 </AMOUNT>
    <Date> date3 </DATE> <AMOUNT> Amount3 </AMOUNT>
    </ENTRY>
    AND SO ON.....

Please let me know if there's need for further clarification.

I am not good at VBA, I am just trying to simplify my work. Thanks in advance.

CodePudding user response：

Compare each row to previous row and next row to determine if start or end of group.

Sub macro1()

    Dim ws As Worksheet
    Dim r As Long, c As Long, lastrow As Long
    Dim xml As String, tag As String, total As Double
  
    Set ws = Sheet1
    With ws
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 2 To lastrow
            If .Cells(r, 1) <> .Cells(r - 1, 1) Then
                tag = .Cells(1, 4) & ">"
                xml = xml & "<ENTRY>" & vbLf & _
                "<" & tag & .Cells(r, 4) & "</" & tag & vbLf
                total = 0
            End If
      
            For c = 2 To 3
                tag = .Cells(1, c) & ">"
                xml = xml & "<" & tag & _
                .Cells(r, c) & "</" & tag
            Next
            xml = xml & vbLf
            
            total = total   .Cells(r, 3).Value2 ' amount
            If .Cells(r   1, 1) <> .Cells(r, 1) Then
                xml = xml & "<Total>" & Format(total, "0.00") & "</Total>" & _
                vbLf & "</ENTRY>" & vbLf
            End If
        Next
    End With
    xml = "<DATA>" & vbLf & xml & "</DATA>"
    
    ' output text file
    Const XMLFILE = "output.xml"
    Dim FSO As Object, ts As Object, filename As String
    Set FSO = CreateObject("Scripting.FilesystemObject")
    filename = ThisWorkbook.Path & "\" & XMLFILE
    Set ts = FSO.createtextfile(filename, overwrite:=True, Unicode:=True)
    ts.write xml
    ts.Close
    
    MsgBox "Done see " & filename, vbInformation
    Shell "Notepad.exe " & filename, 1
    
End Sub