VBA to copy adjacent cells values to another adjacent cells

[Nitin Suntwal]

Hi There,

Attached is the file I am working with. The data i have extracted from SQL database.
I need to copy invoices details to adjacent cells. There may be cases where I may get more than 2 or 3 invoices from each sale order. The conditions are as follows:
Condition 1 : If the RO # (Sales Order #) is repeated then check Inv#'s. If there is only 1 invoice then nothing. If there are 2 invoice with same invoice # then delete dup invoice row.
Condition 2 : If the RO # (Sales Order #) is repeated twice then check Inv#'s. If there are more than 1 invoice then check Inv#'s for same SO & move to adjacent cells in same row and delete below row after copying Invoices details.
Condition 2 : If the RO # (Sales Order #) is repeated more than twice then same as condition 2 but the third invoice details will move to second invoice details row & delete both rows after copying invoices details.

Column A to G are sales orders
Column H to M are invoice details

I have given sample format in Final Data Sheet.
A2 & A3 is condition 1
A4 is condition 2
A5 is condition 3

& finally the headers should be updated to adjacent cells

Hope I am clear.
Thanks,
Nitin.

 

[jindon]

For the data layouts provided.

Sub test()
    Dim a, i As Long, ii As Long, iii As Long, ub As Long
    Dim txt As String, w
    a = Sheets("RO Data").[a3].CurrentRegion.Value: ub = UBound(a, 2)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 4 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                ReDim w(1 To 3)
                Set w(1) = CreateObject("Scripting.Dictionary")
                w(1).CompareMode = 1: w(1)(a(i, 8)) = Empty
                w(2) = .Count + 4: w(3) = ub
                For ii = 1 To ub
                    a(w(2), ii) = a(i, ii)
                Next
            Else
                w = .Item(a(i, 1))
                If Not w(1).exists(a(i, 8)) Then
                    w(3) = w(3) + 6
                    If UBound(a, 2) < w(3) Then
                        ReDim Preserve a(1 To UBound(a, 1), 1 To w(3))
                    End If
                    For ii = 8 To ub
                        a(w(2), w(3) - 6 + ii - 7) = a(i, ii)
                    Next
                End If
            End If
            .Item(a(i, 1)) = w
        Next
        i = .Count + 3
    End With
    With Sheets.Add.Cells(1).Resize(i, UBound(a, 2))
        .Value = a
        If UBound(a, 2) > ub Then
            With .Cells(3, 8).Resize(, ub - 8 + 1)
                .AutoFill .Resize(, UBound(a, 2) - 7)
            End With
        End If
        .Columns.AutoFit
    End With
End Sub

 

[Nitin Suntwal]

Hi J,

Thanks a ton your coding is extraordinary, mind blowing & super fast code. Will get back to you if any questions

 

[Nitin Suntwal]

Hi J,

Your code is perfect no need to do any changes just small change in report. I have attached it for your reference. RO Tracker Sheet1 is my final output which i have to do after your code is run. I tried to do some changes but unable to get it. If possible do some changes.

 

[jindon]

Not really clear to me.

If you upload a workbook with the result filled, it may help to understand.

 

[Nitin Suntwal]

Sorry J, I forgot to update the sheet.

The RO Data sheet will be used to extract data from sql & that is the exact format which i will be getting. Additional column has been added in query to get company name & the first invoice balance. You can ignore the first invoice balance if U want. I will remove the balance column from my query, I think that will be good. Now the RO tracker sheet1 is my final output will be getting from ur code. the only problem is the balance total.
Example if you see the first sale order (RO #) which is repeated 3 times & the quantity is 10 & total amount is 10000. And for the same RO # there are 3 invoices with different quantity and amount which equals the RO quantity & amount.

 

[jindon]

See

Sub test()
    Dim a, i As Long, ii As Long, iii As Long, ub As Long
    Dim txt As String, w
    a = Sheets("RO Data").Cells(1).CurrentRegion.Value: ub = UBound(a, 2)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 2)) Then
                ReDim w(1 To 3)
                Set w(1) = CreateObject("Scripting.Dictionary")
                w(1).CompareMode = 1: w(1)(a(i, 9)) = Empty
                w(2) = .Count + 2: w(3) = ub
                For ii = 1 To ub
                    a(w(2), ii) = a(i, ii)
                Next
            Else
                w = .Item(a(i, 2))
                If Not w(1).exists(a(i, 9)) Then
                    w(3) = w(3) + 7
                    If UBound(a, 2) < w(3) Then
                        ReDim Preserve a(1 To UBound(a, 1), 1 To w(3))
                    End If
                    For ii = 9 To ub
                        a(w(2), w(3) - 7 + ii - 8) = a(i, ii)
                    Next
                End If
            End If
            .Item(a(i, 2)) = w
        Next
        i = .Count + 1
    End With
    With Sheets("RO Tracker Sheet").[b3].Resize(i, UBound(a, 2))
        .CurrentRegion.Offset(2, 1).ClearContents
        .Value = a
        If UBound(a, 2) > ub Then
            With .Cells(1, 9).Resize(, ub - 8)
                .AutoFill .Resize(, UBound(a, 2) - 8)
            End With
        End If
        .Columns.AutoFit
    End With
End Sub

 

[Nitin Suntwal]

Thank You Very Muck J....