Need help writing a Do Until Loop (VBA)

[min9af]

Hi all!

I am wondering if it's possible to write a do until loop that would read through all entries of one ID and do a function and then move onto the next ID.
- The IDs are structured XXX.1.0001 (and goes up to XXX.1.0626, but will likely continue to increase)
- My main point of confusion right now is that each ID has a variable number of entries and I need the do until loop to read through all entries before moving onto the next.
- Once I get the do until loop figured out, I'm hoping to add a nested if statement that will allow me to sort entries for each ID by date and a binary variable

Thanks for your help!

 

[Joe4]

Welcome to the Board!

It is difficult to provide specific instruction to a very vague request. I think it will be beneficial for us to see a sample of what your data looks like, and what you are ultimately trying to accomplish.
There are tools here that will allow you to post images. See here: XL2BB - Excel Range to BBCode

 

[min9af]

Thanks, is this less vague? I have what's on the left and am trying to generate the table on the right (or something similar).

example_for_mrexcel.xlsx
	A	B	C	D	E	F	G	H	I	J	K
1	ID	Date	Test Type		ID	Timepoint 1	A	B	Timepoint 2	A	B
2	XXX.1.0001	3/31/2020	A		XXX.1.0001	3/31/2020	1	0	4/2/2020	0	1
3	XXX.1.0001	4/2/2020	B		XXX.1.0002	3/31/2020	1	0	4/8/2020	1	1
4	XXX.1.0001	4/3/2020	A		XXX.1.0003	4/6/2020	1	0	4/7/2020	1	0
5	XXX.1.0001	4/15/2020	A
6	XXX.1.0001	4/15/2020	B
7	XXX.1.0002	3/31/2020	A
8	XXX.1.0002	4/8/2020	B
9	XXX.1.0002	4/8/2020	A
10	XXX.1.0002	4/9/2020	A
11	XXX.1.0002	4/10/2020	B
12	XXX.1.0002	4/20/2020	A
13	XXX.1.0003	4/6/2020	A
14	XXX.1.0003	4/7/2020	A
15	XXX.1.0003	4/10/2020	B
16	XXX.1.0003	4/15/2020	A
17
Sheet2

 

[Larry Haydn]

I have done this, but have not work on the specific format you want:

VBA Samples.xlsm
	A	B	C	D	E	F	G	H
1	ID	Date	Test Type		ID	Date
2	XXX.1.001	03/31/2020	A		XXX.1.001	03/31/2020	1
3	XXX.1.001	04/02/2020	B		XXX.1.001	04/02/2020		1
4	XXX.1.001	04/03/2020	A		XXX.1.001	04/03/2020	1
5	XXX.1.001	04/15/2020	A		XXX.1.001	04/15/2020	1	1
6	XXX.1.001	04/15/2020	B		XXX.1.002	03/31/2020	1
7	XXX.1.002	03/31/2020	A		XXX.1.002	04/08/2020	1	1
8	XXX.1.002	04/08/2020	B		XXX.1.002	04/09/2020	1
9	XXX.1.002	04/08/2020	A		XXX.1.002	04/10/2020		1
10	XXX.1.002	04/09/2020	A		XXX.1.002	04/20/2020	1
11	XXX.1.002	04/10/2020	B		XXX.1.003	04/06/2020	1
12	XXX.1.002	04/20/2020	A		XXX.1.003	04/07/2020	1
13	XXX.1.003	04/06/2020	A		XXX.1.003	04/10/2020		1
14	XXX.1.003	04/07/2020	A		XXX.1.003	04/15/2020	1
15	XXX.1.003	04/10/2020	B
16	XXX.1.003	04/15/2020	A
TestData

The code is as follows:

Sub FindTestType()
'=============================================
'   Find the test type for each ID and Date
'=============================================
Dim TData As Worksheet
Dim LastRow As Long
Dim ResultRow As Long
Dim DataRow As Long
Dim LastDataRow As Long
Dim LastResultRow As Long

    '===============================
    '   Turn off screen updating
    '===============================
    Application.ScreenUpdating = True
   
    '===================================================
    '   Assign the variable to the worksheet TestData
    '===================================================
    Set TData = ActiveWorkbook.Sheets("TestData")
   
    '============================
    '   Find the last data row
    '============================
    LastRow = TData.Range("A1048576").End(xlUp).Row
   
    '=====================================================
    '   Copy the data columns A and B to column E and F
    '=====================================================
    TData.Range("A1:B" & LastRow).Copy Destination:=TData.Range("E1")
   
    '=========================================
    '   Clear away any existing sort fields
    '=========================================
    TData.Sort.SortFields.Clear
   
        '======================================
        '   Add the first sort field - Col E
        '======================================
        TData.Sort.SortFields.Add2 _
            Key:=Range("E2:E" & LastRow), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal
           
        '=======================================
        '   Add the second sort field - Col F
        '=======================================
        TData.Sort.SortFields.Add2 _
            Key:=Range("F2:F" & LastRow), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal

            '======================
            '   Execute the Sort
            '======================
            With TData.Sort
                .SetRange Range("E1:F" & LastRow)
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
           
        '===============================
        '   Remove duplicates, if any
        '===============================
        TData.Range("$E$1:$F$16").RemoveDuplicates _
            Columns:=Array(1, 2), _
            Header:=xlYes
   
    '=======================
    '   Define the:
    '   * Last Data Row
    '   * Last Result Row
    '=======================
    LastDataRow = LastRow   'We found this earlier. Change variable name for clarity
    LastResultRow = TData.Range("E1048576").End(xlUp).Row
   
    '======================================
    '   Run a loop to find the Test Type
    '======================================
    For ResultRow = 2 To LastDataRow
   
        For DataRow = 2 To LastDataRow
       
            '===================================================
            '   Find the data row that matches the result row
            '===================================================
            If TData.Range("E" & ResultRow) = TData.Range("A" & DataRow) And _
               TData.Range("F" & ResultRow) = TData.Range("B" & DataRow) Then
               '====================================================
               '   Check the test type and write to column G or H
               '====================================================
               If TData.Range("C" & DataRow) = "A" Then
                    '===========================
                    '   Add count to column G
                    '===========================
                    TData.Range("G" & ResultRow) = TData.Range("G" & ResultRow) + 1
                   
               ElseIf TData.Range("C" & DataRow) = "B" Then
                    '===========================
                    '   Add count to column H
                    '===========================
                    TData.Range("H" & ResultRow) = TData.Range("H" & ResultRow) + 1
               End If
              
            End If
       
        Next DataRow
       
    Next ResultRow
   
    '===============================
    '   Turn back screen updating
    '===============================
    Application.ScreenUpdating = True


End Sub

 

[Larry Haydn]

Thanks for the formatting!

 

[min9af]

Thanks so much! Is it possible to copy and paste the test type into columns G & H instead of doing a count? I tried substituting several variations of this into 'Add count to column G'

 TData.Range("G" & ResultRow) = TData.Range("C" & ResultRow).Copy Destination:=TData.Range("G" & ResultRow)

but I ran into several errors.

Thanks again!

 

[Larry Haydn]

Sorry for the late reply.

Here is the new code. It caters for 10 Timepoints.
You can add more Timepoints if needed (by adding the headings, as well as the CASE statements).
Have fun!

Option Compare Text

Sub FindTestType()
'=============================================
'   Find the test type for each ID and Date
'=============================================
Dim TData As Worksheet

Dim DataRow As Long
Dim ResultRow As Long

Dim LastDataRow As Long
Dim LastIDRow As Long

Dim ResultID As String
Dim PrevDataID As String
Dim NewDataID As String

Dim TestCountForThisDate As Integer

    '===============================
    '   Turn off screen updating
    '===============================
    Application.ScreenUpdating = True

    '===================================================
    '   Assign the variable to the worksheet TestData
    '===================================================
    Set TData = ActiveWorkbook.Sheets("TestData")
    
    '=============================
    '   Delete previous results
    '=============================
    TData.Columns("E:AZ").EntireColumn.Delete
    
    '============================
    '   Find the last data row
    '============================
    LastDataRow = TData.Range("A1048576").End(xlUp).Row
    
    '=========================================
    '   Clear away any existing sort fields
    '=========================================
    TData.Sort.SortFields.Clear
    
        '======================================
        '   Add the first sort field - Col A
        '======================================
        TData.Sort.SortFields.Add2 _
            Key:=Range("A2:A" & LastDataRow), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal
            
        '=======================================
        '   Add the second sort field - Col B
        '=======================================
        TData.Sort.SortFields.Add2 _
            Key:=Range("B2:B" & LastDataRow), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal

            '======================
            '   Execute the Sort
            '======================
            With TData.Sort
                .SetRange Range("A1:C" & LastDataRow)
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            
    '================================================
    '   Now that the data is sorted by ID and Date
    '   You will copy the ID to column E
    '   then remove the duplicate ID
    '================================================
    TData.Range("A1:A" & LastDataRow).Copy Destination:=TData.Range("E1")
        '=======================
        '   Remove duplicates
        '=======================
        LastIDRow = TData.Range("E1048576").End(xlUp).Row
        TData.Range("$E$1:$E" & LastIDRow).RemoveDuplicates _
            Columns:=1, _
            Header:=xlYes
    
        '================================
        '   Insert the result headings
        '================================
        With TData
            .Range("F1") = "Timepoint 1"
            .Range("G1") = "A"
            .Range("H1") = "B"
            
            .Range("I1") = "Timepoint 2"
            .Range("J1") = "A"
            .Range("K1") = "B"
            
            .Range("L1") = "Timepoint 3"
            .Range("M1") = "A"
            .Range("N1") = "B"
            
            .Range("O1") = "Timepoint 4"
            .Range("P1") = "A"
            .Range("Q1") = "B"
            
            .Range("R1") = "Timepoint 5"
            .Range("S1") = "A"
            .Range("T1") = "B"
            
            .Range("U1") = "Timepoint 6"
            .Range("V1") = "A"
            .Range("W1") = "B"
            
            .Range("X1") = "Timepoint 7"
            .Range("Y1") = "A"
            .Range("Z1") = "B"
            
            .Range("AA1") = "Timepoint 8"
            .Range("AB1") = "A"
            .Range("AC1") = "B"
            
            .Range("AD1") = "Timepoint 9"
            .Range("AE1") = "A"
            .Range("AF1") = "B"
            
            .Range("AG1") = "Timepoint 10"
            .Range("AH1") = "A"
            .Range("AI1") = "B"
            
            'ADD MORE IF NEEDED
            
            '==================================
            '   Format the Timepoint columns
            '==================================
            .Columns("F:F").NumberFormat = "dd/mm/yyyy"
            .Columns("I:I").NumberFormat = "dd/mm/yyyy"
            .Columns("L:L").NumberFormat = "dd/mm/yyyy"
            .Columns("O:O").NumberFormat = "dd/mm/yyyy"
            .Columns("R:R").NumberFormat = "dd/mm/yyyy"
            
            .Columns("U:U").NumberFormat = "dd/mm/yyyy"
            .Columns("X:X").NumberFormat = "dd/mm/yyyy"
            .Columns("AA:AA").NumberFormat = "dd/mm/yyyy"
            .Columns("AD:AD").NumberFormat = "dd/mm/yyyy"
            .Columns("AG:AG").NumberFormat = "dd/mm/yyyy"
            
            '=================================
            '   Format the Test Type values
            '=================================
            .Columns("G:H").NumberFormat = "0"
            .Columns("J:K").NumberFormat = "0"
            .Columns("M:N").NumberFormat = "0"
            .Columns("P:Q").NumberFormat = "0"
            .Columns("S:T").NumberFormat = "0"
            
            .Columns("V:W").NumberFormat = "0"
            .Columns("Y:Z").NumberFormat = "0"
            .Columns("AB:AC").NumberFormat = "0"
            .Columns("AE:AF").NumberFormat = "0"
            .Columns("AH:AI").NumberFormat = "0"
            
            '=================================
            '   Data alignment in the cells
            '=================================
            .Columns("E:AZ").HorizontalAlignment = xlCenter
            .Columns("E:AZ").VerticalAlignment = xlCenter
            
        End With

    '---------------------------------------------------------------------
    '   Next, we need a placeholder to identify the ID (on the results)
    '   Also, as we loop through the data
    '      we have to check whether the
    '         current ID (data) matches the current ID (results)
    '      so that we know to which row we copy the data
    '---------------------------------------------------------------------
    
    '=====================================
    '   Initialize (set initial values)
    '=====================================
    ResultRow = 2
    DataRow = 2
    PrevDataID = TData.Range("A" & ResultRow)
    TestCountForThisDate = 0
    
        '=================================
        '   Loop through the result IDs
        '=================================
        Do While TData.Range("E" & ResultRow) <> ""
            '=============================
            '   Get the ID for this row
            '=============================
            ResultID = TData.Range("E" & ResultRow)
            Debug.Print "ResultRow = " & ResultRow & " - ResultID = " & ResultID
                '===========================
                '   Loop through the data
                '===========================
                Do While TData.Range("A" & DataRow) <> ""
                    '=====================
                    '   Get the Data ID
                    '=====================
                    NewDataID = TData.Range("A" & DataRow)
                    Debug.Print "   Data Row = " & DataRow & " - NewDataID = " & NewDataID
                        '==================================================================
                        '   If the Data ID is the same as Result ID then copy the result
                        '==================================================================
                        If NewDataID = PrevDataID Then
                            '==================================
                            '   Set the TestCountForThisDate
                            '==================================
                            TestCountForThisDate = TestCountForThisDate + 1
                                '===============================
                                '   Copy the Data ID and Date
                                '===============================
                                Select Case TestCountForThisDate
                                
                                    Case 1
                                        TData.Range("B" & DataRow).Copy TData.Range("F" & ResultRow)
                                        If TData.Range("C" & DataRow) = "A" Then
                                            TData.Range("G" & ResultRow) = TData.Range("G" & ResultRow) + 1
                                        ElseIf TData.Range("C" & DataRow) = "B" Then
                                            TData.Range("H" & ResultRow) = TData.Range("H" & ResultRow) + 1
                                        End If
                                        
                                    Case 2
                                        TData.Range("B" & DataRow).Copy TData.Range("I" & ResultRow)
                                        If TData.Range("C" & DataRow) = "A" Then
                                            TData.Range("J" & ResultRow) = TData.Range("J" & ResultRow) + 1
                                        ElseIf TData.Range("C" & DataRow) = "B" Then
                                            TData.Range("K" & ResultRow) = TData.Range("K" & ResultRow) + 1
                                        End If
                                
                                    Case 3
                                        TData.Range("B" & DataRow).Copy TData.Range("L" & ResultRow)
                                        If TData.Range("C" & DataRow) = "A" Then
                                            TData.Range("M" & ResultRow) = TData.Range("M" & ResultRow) + 1
                                        ElseIf TData.Range("C" & DataRow) = "B" Then
                                            TData.Range("N" & ResultRow) = TData.Range("N" & ResultRow) + 1
                                        End If
                                                                
                                    Case 4
                                        TData.Range("B" & DataRow).Copy TData.Range("O" & ResultRow)
                                        If TData.Range("C" & DataRow) = "A" Then
                                            TData.Range("P" & ResultRow) = TData.Range("P" & ResultRow) + 1
                                        ElseIf TData.Range("C" & DataRow) = "B" Then
                                            TData.Range("Q" & ResultRow) = TData.Range("Q" & ResultRow) + 1
                                        End If
                                                                                                
                                    Case 5
                                        TData.Range("B" & DataRow).Copy TData.Range("R" & ResultRow)
                                        If TData.Range("C" & DataRow) = "A" Then
                                            TData.Range("S" & ResultRow) = TData.Range("S" & ResultRow) + 1
                                        ElseIf TData.Range("C" & DataRow) = "B" Then
                                            TData.Range("T" & ResultRow) = TData.Range("T" & ResultRow) + 1
                                        End If
                                
                                    Case 6
                                        TData.Range("B" & DataRow).Copy TData.Range("U" & ResultRow)
                                        If TData.Range("C" & DataRow) = "A" Then
                                            TData.Range("V" & ResultRow) = TData.Range("V" & ResultRow) + 1
                                        ElseIf TData.Range("C" & DataRow) = "B" Then
                                            TData.Range("W" & ResultRow) = TData.Range("W" & ResultRow) + 1
                                        End If
                                        
                                    Case 7
                                        TData.Range("B" & DataRow).Copy TData.Range("X" & ResultRow)
                                        If TData.Range("C" & DataRow) = "A" Then
                                            TData.Range("Y" & ResultRow) = TData.Range("Y" & ResultRow) + 1
                                        ElseIf TData.Range("C" & DataRow) = "B" Then
                                            TData.Range("Z" & ResultRow) = TData.Range("Z" & ResultRow) + 1
                                        End If
                                        
                                    Case 8
                                        TData.Range("B" & DataRow).Copy TData.Range("AA" & ResultRow)
                                        If TData.Range("C" & DataRow) = "A" Then
                                            TData.Range("AB" & ResultRow) = TData.Range("AB" & ResultRow) + 1
                                        ElseIf TData.Range("C" & DataRow) = "B" Then
                                            TData.Range("AC" & ResultRow) = TData.Range("AC" & ResultRow) + 1
                                        End If
                                        
                                    Case 9
                                        TData.Range("B" & DataRow).Copy TData.Range("AD" & ResultRow)
                                        If TData.Range("C" & DataRow) = "A" Then
                                            TData.Range("AE" & ResultRow) = TData.Range("AE" & ResultRow) + 1
                                        ElseIf TData.Range("C" & DataRow) = "B" Then
                                            TData.Range("AF" & ResultRow) = TData.Range("AF" & ResultRow) + 1
                                        End If
                                        
                                    Case 10
                                        TData.Range("B" & DataRow).Copy TData.Range("AG" & ResultRow)
                                        If TData.Range("C" & DataRow) = "A" Then
                                            TData.Range("AH" & ResultRow) = TData.Range("AH" & ResultRow) + 1
                                        ElseIf TData.Range("C" & DataRow) = "B" Then
                                            TData.Range("AI" & ResultRow) = TData.Range("AI" & ResultRow) + 1
                                        End If
                                        
                                    'Add more if required
                                                                
                                End Select
                        
                        Else
                            '==========================================
                            '   Different test ID, so exit this loop
                            '==========================================
                            TestCountForThisDate = 0
                            PrevDataID = NewDataID
                            Exit Do
                        
                        End If
                
                    '===================
                    '   Next Data Row
                    '===================
                    DataRow = DataRow + 1
                
                Loop 'until no more data
        
            '=====================
            '   Next Result Row
            '=====================
            ResultRow = ResultRow + 1
            
        Loop 'until no more result ID
    
    '=========================
    '   Autofit the columns
    '=========================
    TData.Columns("A:AZ").AutoFit
    
    '===============================
    '   Turn back screen updating
    '===============================
    Application.ScreenUpdating = True


End Sub

 

[Larry Haydn]

Here is a screenshot of the result: