Help jump Columns

[vidaLL]

Hi all.
I need a little help with my Sheets.

Desktop.zip

If you put the Sheets in your desktop and click in the button(TEST) in Plan1 Sheet ,
will start to fill in the fields.

However I would like each of the values were filled in the column painted in blue.

Any doubt let me know.

Ty all

[Bob Phillips]

Sub BuscaSQL1()
    Dim ConecaoPlan As ADODB.Connection
    Dim rsConsulta As ADODB.Recordset
    Dim Caminho As String
    Dim Roda As Integer
    Dim sql As String
    
                  '/////////// - 2110 - ///////////'
    Caminho = ActiveWorkbook.Path & "\2110(2).xlsm"
'
    ConecaoPlan.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=""" & Caminho & """;Extended Properties=Excel 8.0;"
    '";Extended Properties=Excel 12.0 Xml;HDR=YES;"Extended Properties=Excel 8.0
    ConecaoPlan.Open
    
    With Range("B10")
    
        Do While ActiveCell.Value <> "Total AR"
    
            sql = "Select * From [MontaBase$] Where Dado1 Like '" & ActiveCell.Value & "'"
            Set rsConsulta = ConecaoPlan.Execute(sql)
                    
            If rsConsulta.RecordCount > 0 Then
            
                For Roda = 1 To 28 Step 5
                
                    Cells(.Row, .Column + Roda).Value = rsConsulta!Dado2
                    rsConsulta.MoveNext
                Next
                End If
    
            rsConsulta.Close
        Loop
    End With
    
    Set ConecaoPlan = Nothing
    Set rsConsulta = Nothing
End Sub

[vidaLL]

Sub BuscaSQL1()
    Dim ConecaoPlan As ADODB.Connection
    Dim rsConsulta As ADODB.Recordset
    Dim Caminho As String
    Dim Roda As Integer
    Dim sql As String
    
                  '/////////// - 2110 - ///////////'
    Caminho = ActiveWorkbook.Path & "\2110(2).xlsm"
'
    ConecaoPlan.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=""" & Caminho & """;Extended Properties=Excel 8.0;"
    '";Extended Properties=Excel 12.0 Xml;HDR=YES;"Extended Properties=Excel 8.0
    ConecaoPlan.Open
    
    With Range("B10")
    
        Do While ActiveCell.Value <> "Total AR"
    
            sql = "Select * From [MontaBase$] Where Dado1 Like '" & ActiveCell.Value & "'"
            Set rsConsulta = ConecaoPlan.Execute(sql)
                    
            If rsConsulta.RecordCount > 0 Then
            
                For Roda = 1 To 28 Step 5
                
                    Cells(.Row, .Column + Roda).Value = rsConsulta!Dado2
                    rsConsulta.MoveNext
                Next
                End If
    
            rsConsulta.Close
        Loop
    End With
    
    Set ConecaoPlan = Nothing
    Set rsConsulta = Nothing
End Sub

Thanks very much . It Works like a charm.

[vidaLL]

Let's think there is already filled data in this spreadsheet (Annex) and this new information will be filled by the macro, keeping the information that was already filled.
Any idea how can I do this?

Desktop.zip

Thanks again.