Support required for the Macro

Rohith1324

Board Regular
Joined
Feb 27, 2018
Messages
101
I have below data in excel sheet (Data 1 - Highlighted in the below screenshot) I would need a macro which can convert the data into Invoice content (Data 2 - Highlighted in the below screenshot).

Logic:
1) Before running the Macro, In Excel sheet "Column I to N" - Highlighted in the below screenshot will be blank (No Headers nothing just the normal cells)
2) In Column A - I have the Unique ID Number so basis on that Invoice Content to be prepared.
3) If you observe each Unique number has multiple categories (Column F - FRUIT, CLOTHES, VEGETABLE, CHOCOLATE, OIL..etc) involved.
4) When I execute the macro the header in COLUMN I to N to be prepared (If I have 10 Unique numbers ((Column A) then 10 Invoice contents to be prepared one below the other - in this example I'm showing 3 Invoice contents).
5) One unique ID number (Column A) if it is having suppose 2 Categories then in 2 Lines Unique ID number to reflect (Column I) and then after removing duplicate Macro to paste the categories.
6) By default, Qty to reflect in the lines as "1 Set" - Standard.
7) For 1 Unique ID Number & Category we need to take the Value and paste it under both Unit Value & Total Value columns.
8) Finally in the Column N Passcode of that Category must be picked from Data 1 and then update the Invoice content Data 2.
9) For each unique ID separate Invoice content to be created with Numbering as Invoice 1, Invoice 2, Invoice 3

Please help me with Macro...



1652637511367.png
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

ranman256

Well-known Member
Joined
Jun 17, 2014
Messages
2,198
this is what Microsoft Access if for. The database can do this easily.
Don't use a screwdriver to hammer nails.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
15,234
Office Version
  1. 2013
Platform
  1. Windows
Put all of the following code into one module. Run the "convert_data_into_Invoice" macro.

VBA Code:
Sub convert_data_into_Invoice()
  Dim a As Variant, b As Variant, ky As Variant
  Dim i As Long, j As Long, n As Long, x As Long, y As Long
  Dim dic1 As Object, dic2 As Object
  Dim cad As String
  Dim tot As Double
  
  Application.ScreenUpdating = False
  a = Range("A1:G" & Range("A" & Rows.Count).End(3).Row + 1).Value
  Range("I:N").Clear

  Set dic1 = CreateObject("Scripting.dictionary")
  Set dic2 = CreateObject("Scripting.dictionary")
  ReDim b(1 To UBound(a, 1) * 4, 1 To 6)
  
  For i = 2 To UBound(a, 1)
    If a(i, 1) = "" Then a(i, 1) = "last"
    cad = a(i, 1) & "|" & a(i, 7)
    If Not dic2.exists(cad) Then
      y = y + 1
      dic2(cad) = y
    End If
    n = dic2(cad)
    b(n, 1) = a(i, 1)
    b(n, 2) = a(i, 6)
    b(n, 3) = "1 Set"
    b(n, 4) = b(n, 4) + a(i, 3)
    b(n, 5) = b(n, 4)
    b(n, 6) = a(i, 7)
  Next
  
  i = 1
  For n = 1 To y
    ky = Split(b(n, 1), "|")(0)
    If Not dic1.exists(ky) Then
      If i > 1 Then
        Call ValueAndFormats(Range("M" & i + 1), tot)
        i = i + 3
        If ky = "last" Then Exit Sub
      End If
      x = x + 1
      dic1(ky) = x
      
      'Values and Formats
      Call ValueAndFormats(Range("I" & i), "Invoice " & x)
      Call ValueAndFormats(Range("I" & i + 1).Resize(1, 6), Array([A1], [F1], "Qty", "Unit Value", "Total", "HSN"))
      
      i = i + 2
      tot = b(n, 5)
    Else
      tot = tot + b(n, 5)
      i = i + 1
    End If
    
    For j = 1 To 6
      Cells(i, j + 8) = b(n, j)
    Next
    With Range("I" & i).Resize(1, 6)
      .Borders.LineStyle = xlContinuous
      .Offset(, 1).Resize(1, 4).HorizontalAlignment = xlCenter
    End With
  Next
  
  Application.ScreenUpdating = True
End Sub

Sub ValueAndFormats(rng As Range, vle As Variant)
  With rng
    .Value = vle
    .Interior.Color = 12611584
    .Font.Color = vbWhite
    .HorizontalAlignment = xlCenter
    .Borders.LineStyle = xlContinuous
  End With
End Sub
 
Solution

Rohith1324

Board Regular
Joined
Feb 27, 2018
Messages
101
Put all of the following code into one module. Run the "convert_data_into_Invoice" macro.

VBA Code:
Sub convert_data_into_Invoice()
  Dim a As Variant, b As Variant, ky As Variant
  Dim i As Long, j As Long, n As Long, x As Long, y As Long
  Dim dic1 As Object, dic2 As Object
  Dim cad As String
  Dim tot As Double
 
  Application.ScreenUpdating = False
  a = Range("A1:G" & Range("A" & Rows.Count).End(3).Row + 1).Value
  Range("I:N").Clear

  Set dic1 = CreateObject("Scripting.dictionary")
  Set dic2 = CreateObject("Scripting.dictionary")
  ReDim b(1 To UBound(a, 1) * 4, 1 To 6)
 
  For i = 2 To UBound(a, 1)
    If a(i, 1) = "" Then a(i, 1) = "last"
    cad = a(i, 1) & "|" & a(i, 7)
    If Not dic2.exists(cad) Then
      y = y + 1
      dic2(cad) = y
    End If
    n = dic2(cad)
    b(n, 1) = a(i, 1)
    b(n, 2) = a(i, 6)
    b(n, 3) = "1 Set"
    b(n, 4) = b(n, 4) + a(i, 3)
    b(n, 5) = b(n, 4)
    b(n, 6) = a(i, 7)
  Next
 
  i = 1
  For n = 1 To y
    ky = Split(b(n, 1), "|")(0)
    If Not dic1.exists(ky) Then
      If i > 1 Then
        Call ValueAndFormats(Range("M" & i + 1), tot)
        i = i + 3
        If ky = "last" Then Exit Sub
      End If
      x = x + 1
      dic1(ky) = x
     
      'Values and Formats
      Call ValueAndFormats(Range("I" & i), "Invoice " & x)
      Call ValueAndFormats(Range("I" & i + 1).Resize(1, 6), Array([A1], [F1], "Qty", "Unit Value", "Total", "HSN"))
     
      i = i + 2
      tot = b(n, 5)
    Else
      tot = tot + b(n, 5)
      i = i + 1
    End If
   
    For j = 1 To 6
      Cells(i, j + 8) = b(n, j)
    Next
    With Range("I" & i).Resize(1, 6)
      .Borders.LineStyle = xlContinuous
      .Offset(, 1).Resize(1, 4).HorizontalAlignment = xlCenter
    End With
  Next
 
  Application.ScreenUpdating = True
End Sub

Sub ValueAndFormats(rng As Range, vle As Variant)
  With rng
    .Value = vle
    .Interior.Color = 12611584
    .Font.Color = vbWhite
    .HorizontalAlignment = xlCenter
    .Borders.LineStyle = xlContinuous
  End With
End Sub
Thank you so much DanteAmor....it was just like a magic.....
 

Rohith1324

Board Regular
Joined
Feb 27, 2018
Messages
101
Put all of the following code into one module. Run the "convert_data_into_Invoice" macro.

VBA Code:
Sub convert_data_into_Invoice()
  Dim a As Variant, b As Variant, ky As Variant
  Dim i As Long, j As Long, n As Long, x As Long, y As Long
  Dim dic1 As Object, dic2 As Object
  Dim cad As String
  Dim tot As Double
 
  Application.ScreenUpdating = False
  a = Range("A1:G" & Range("A" & Rows.Count).End(3).Row + 1).Value
  Range("I:N").Clear

  Set dic1 = CreateObject("Scripting.dictionary")
  Set dic2 = CreateObject("Scripting.dictionary")
  ReDim b(1 To UBound(a, 1) * 4, 1 To 6)
 
  For i = 2 To UBound(a, 1)
    If a(i, 1) = "" Then a(i, 1) = "last"
    cad = a(i, 1) & "|" & a(i, 7)
    If Not dic2.exists(cad) Then
      y = y + 1
      dic2(cad) = y
    End If
    n = dic2(cad)
    b(n, 1) = a(i, 1)
    b(n, 2) = a(i, 6)
    b(n, 3) = "1 Set"
    b(n, 4) = b(n, 4) + a(i, 3)
    b(n, 5) = b(n, 4)
    b(n, 6) = a(i, 7)
  Next
 
  i = 1
  For n = 1 To y
    ky = Split(b(n, 1), "|")(0)
    If Not dic1.exists(ky) Then
      If i > 1 Then
        Call ValueAndFormats(Range("M" & i + 1), tot)
        i = i + 3
        If ky = "last" Then Exit Sub
      End If
      x = x + 1
      dic1(ky) = x
     
      'Values and Formats
      Call ValueAndFormats(Range("I" & i), "Invoice " & x)
      Call ValueAndFormats(Range("I" & i + 1).Resize(1, 6), Array([A1], [F1], "Qty", "Unit Value", "Total", "HSN"))
     
      i = i + 2
      tot = b(n, 5)
    Else
      tot = tot + b(n, 5)
      i = i + 1
    End If
   
    For j = 1 To 6
      Cells(i, j + 8) = b(n, j)
    Next
    With Range("I" & i).Resize(1, 6)
      .Borders.LineStyle = xlContinuous
      .Offset(, 1).Resize(1, 4).HorizontalAlignment = xlCenter
    End With
  Next
 
  Application.ScreenUpdating = True
End Sub

Sub ValueAndFormats(rng As Range, vle As Variant)
  With rng
    .Value = vle
    .Interior.Color = 12611584
    .Font.Color = vbWhite
    .HorizontalAlignment = xlCenter
    .Borders.LineStyle = xlContinuous
  End With
End Sub
sorry but just small addition on this can you please help :

I just need one line addition Total Net value and EUR in the output....Please help

1652776514726.png
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
15,234
Office Version
  1. 2013
Platform
  1. Windows
just need one line addition Total Net value and EUR in the output
Try this:

VBA Code:
Sub convert_data_into_Invoice()
  Dim a As Variant, b As Variant, ky As Variant
  Dim i As Long, j As Long, n As Long, y As Long
  Dim dic1 As Object, dic2 As Object
  Dim cad As String, tot As Double
  
  Application.ScreenUpdating = False
  Set dic1 = CreateObject("Scripting.dictionary")
  Set dic2 = CreateObject("Scripting.dictionary")
  a = Range("A1:G" & Range("A" & Rows.Count).End(3).Row + 1).Value
  ReDim b(1 To UBound(a, 1) * 4, 1 To 6)
  Range("I:N").Clear

  For i = 2 To UBound(a, 1)
    If a(i, 1) = "" Then a(i, 1) = "last"
    cad = a(i, 1) & "|" & a(i, 7)
    If Not dic2.exists(cad) Then
      y = y + 1
      dic2(cad) = y
    End If
    n = dic2(cad)
    b(n, 1) = a(i, 1)
    b(n, 2) = a(i, 6)
    b(n, 3) = "1 Set"
    b(n, 4) = b(n, 4) + a(i, 3)
    b(n, 5) = b(n, 4)
    b(n, 6) = a(i, 7)
  Next
  
  i = 1
  For n = 1 To y
    ky = Split(b(n, 1), "|")(0)
    If Not dic1.exists(ky) Then
      If i > 1 Then
        i = i + 1
        Call ValueAndFormats(Range("M" & i), tot)
        Range("J" & i).Resize(1, 3).Value = Array("Total Net value", , "EUR")
        i = i + 2
        If ky = "last" Then Exit Sub
      End If
      'x = x + 1
      dic1(ky) = dic1(ky) + 1
      'Values and Formats
      Call ValueAndFormats(Range("I" & i), "Invoice " & dic1(ky))
      Call ValueAndFormats(Range("I" & i + 1).Resize(1, 6), Array([A1], [F1], "Qty", "Unit Value", "Total", "HSN"))
      i = i + 1
      tot = 0
    End If
    i = i + 1
    tot = tot + b(n, 5)
    
    For j = 1 To 6
      Cells(i, j + 8) = b(n, j)
    Next
    With Range("I" & i).Resize(1, 6)
      .Offset(, 1).Resize(1, 4).HorizontalAlignment = xlCenter
      .Borders.LineStyle = xlContinuous
    End With
  Next
  
  Application.ScreenUpdating = True
End Sub
 

Forum statistics

Threads
1,175,670
Messages
5,898,803
Members
434,731
Latest member
njakfla

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top