Support required for the Macro

R

Rohith1324

Board Regular
Joined
Feb 27, 2018
Messages
114
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 can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
this is what Microsoft Access if for. The database can do this easily.
Don't use a screwdriver to hammer nails.
 
Upvote 0
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
 
Upvote 0
Solution
DanteAmor said:
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
Click to expand...
Thank you so much DanteAmor....it was just like a magic.....
 
Upvote 0
DanteAmor said:
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
Click to expand...
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
 
Upvote 0
Rohith1324 said:
just need one line addition Total Net value and EUR in the output
Click to expand...
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Macro Help,
Replies
3
Views
78
offthelip
O
P
  • Question
Analytics Project - Sumifs
Replies
1
Views
178
bobaol
B
T
  • Question
Viewing data rows from another worksheet in a portal
Replies
1
Views
133
kevin9999
K
M
  • Question
Add new items in Sheet 2 to Sheet 1 in workbook
Replies
0
Views
151
mmackey
M
danhendo888
  • Solved
Using FILTER/UNIQUE on text, numbers
2 3
Replies
24
Views
454
KRice
K

Forum statistics

Threads
1,214,643
Messages
6,120,707
Members
448,981
Latest member
recon11bucks

Share this page

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
Back
Top