Creating labels as PDF with VBA

drag1c

New Member
Joined
Aug 7, 2019
Messages
14
Office Version
  1. 2013
Platform
  1. Windows
Hello,

here below is my Workbook with 2 worksheets.

Worksheet Label and Worksheet Print Packing.

Does anyone have idea about loop through rows of Packing List, to fill Label and save it as pdf for each non-empty row (reference could be ID column in packing list)?

I would go with something like this:

VBA Code:
Sub Print_Labels()

Dim i As Range

    For Each i In Worksheets("Print Packing").Range("A6:A30").Value
        
        If IsEmpty(Range("A6:A30").Value) Then
           End If
          ' this part should copy data to labels and save them as they are each row
            With Sheets("LABEL")
                  .[A11] = Range("E6:E30")
                  .[C16] = Intersect(i.EntireRow, Range("I6:I30"))
                  .[C18] = Intersect(i.EntireRow, Range("N6:N30"))
            End With
                
                ThisWorkbook.Worksheets("LABEL").ExportAsFixedFormat Type:=xlTypePDF, _
                FileName:="C:\Users\logistics.rs\Desktop\New folder\" & & ".pdf"
          Next
        

End Sub

But it does not work, because I do not know to set Filename of PDF between two & & .

If anyone have idea, how this could work, I would be thankful !
Djordje
 

Attachments

  • Label.png
    Label.png
    11 KB · Views: 5
  • Packing List.png
    Packing List.png
    38.3 KB · Views: 5

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

drag1c

New Member
Joined
Aug 7, 2019
Messages
14
Office Version
  1. 2013
Platform
  1. Windows
Hello !
I've edited code a bit, added table and all data packed in that table with vlookup so it is filled up to last filled row (no empty rows between).
VBA Code:
Private Sub CommandButton2_Click()
If MsgBox("This action will create labels in specified folder in PRODUCTION. Are you sure?", vbYesNo) = vbNo Then Exit Sub

Dim c As Range

Set corrange = Worksheets("Print Packing").Range("B2")
Set clirange = Worksheets("Print Packing").Range("O6:O30")
Set ocrange = Worksheets("Print Packing").Range("P6:P30")
Set addressrange = Worksheets("Print Packing").Range("Q6:Q30")
Set addressrange1 = Worksheets("Print Packing").Range("R6:R30")
Set addressrange2 = Worksheets("Print Packing").Range("S6:S30")
Set addressrange3 = Worksheets("Print Packing").Range("T6:T30")
Set icoderange = Worksheets("Print Packing").Range("E6:E30")
Set ccoderange = Worksheets("Print Packing").Range("U6:U30")
Set descrangei = Worksheets("Print Packing").Range("B6:B30")
Set descranges = Worksheets("Print Packing").Range("V6:V30")
Set descrangee = Worksheets("Print Packing").Range("W6:W30")
Set qtyrange = Worksheets("Print Packing").Range("I6:I30")
Set wgtrange = Worksheets("Print Packing").Range("N6:N30")


For Each c In [Table8[ID]]
    With Sheets("LABEL")
        .[B3] = corrange
        .[D3] = Intersect(c.EntireRow, clirange)
        .[B4] = Intersect(c.EntireRow, ocrange)
        .[A6] = Intersect(c.EntireRow, addressrange)
        .[A7] = Intersect(c.EntireRow, addressrange1)
        .[A8] = Intersect(c.EntireRow, addressrange2)
        .[A9] = Intersect(c.EntireRow, addressrange3)
        .[A11] = Intersect(c.EntireRow, icoderange)
        .[A12] = Intersect(c.EntireRow, ccoderange)
        .[A13] = Intersect(c.EntireRow, descrangei)
        .[A14] = Intersect(c.EntireRow, descranges)
        .[A15] = Intersect(c.EntireRow, descrangee)
        .[C16] = Intersect(c.EntireRow, qtyrange)
        .[C18] = Intersect(c.EntireRow, wgtrange)
    End With
    ThisWorkbook.Worksheets("LABEL").ExportAsFixedFormat Type:=xlTypePDF, FileName:="C:\Users\drag1c\Desktop\New folder\" & "COR " & Cor & "-" & ICode & ".pdf"
    Next


End Sub

Unfortunately, it saves just one PDF, with name "COR -" and that's it.
What could be a problem?

Also, how to add counter to save PDFs up to the last filled row in a table?

Thank you very much !
 

drag1c

New Member
Joined
Aug 7, 2019
Messages
14
Office Version
  1. 2013
Platform
  1. Windows
Hello !
I've edited code a bit, added table and all data packed in that table with vlookup so it is filled up to last filled row (no empty rows between).
VBA Code:
Private Sub CommandButton2_Click()
If MsgBox("This action will create labels in specified folder in PRODUCTION. Are you sure?", vbYesNo) = vbNo Then Exit Sub

Dim c As Range

Set corrange = Worksheets("Print Packing").Range("B2")
Set clirange = Worksheets("Print Packing").Range("O6:O30")
Set ocrange = Worksheets("Print Packing").Range("P6:P30")
Set addressrange = Worksheets("Print Packing").Range("Q6:Q30")
Set addressrange1 = Worksheets("Print Packing").Range("R6:R30")
Set addressrange2 = Worksheets("Print Packing").Range("S6:S30")
Set addressrange3 = Worksheets("Print Packing").Range("T6:T30")
Set icoderange = Worksheets("Print Packing").Range("E6:E30")
Set ccoderange = Worksheets("Print Packing").Range("U6:U30")
Set descrangei = Worksheets("Print Packing").Range("B6:B30")
Set descranges = Worksheets("Print Packing").Range("V6:V30")
Set descrangee = Worksheets("Print Packing").Range("W6:W30")
Set qtyrange = Worksheets("Print Packing").Range("I6:I30")
Set wgtrange = Worksheets("Print Packing").Range("N6:N30")


For Each c In [Table8[ID]]
    With Sheets("LABEL")
        .[B3] = corrange
        .[D3] = Intersect(c.EntireRow, clirange)
        .[B4] = Intersect(c.EntireRow, ocrange)
        .[A6] = Intersect(c.EntireRow, addressrange)
        .[A7] = Intersect(c.EntireRow, addressrange1)
        .[A8] = Intersect(c.EntireRow, addressrange2)
        .[A9] = Intersect(c.EntireRow, addressrange3)
        .[A11] = Intersect(c.EntireRow, icoderange)
        .[A12] = Intersect(c.EntireRow, ccoderange)
        .[A13] = Intersect(c.EntireRow, descrangei)
        .[A14] = Intersect(c.EntireRow, descranges)
        .[A15] = Intersect(c.EntireRow, descrangee)
        .[C16] = Intersect(c.EntireRow, qtyrange)
        .[C18] = Intersect(c.EntireRow, wgtrange)
    End With
    ThisWorkbook.Worksheets("LABEL").ExportAsFixedFormat Type:=xlTypePDF, FileName:="C:\Users\drag1c\Desktop\New folder\" & "COR " & Cor & "-" & ICode & ".pdf"
    Next


End Sub

Unfortunately, it saves just one PDF, with name "COR -" and that's it.
What could be a problem?

Also, how to add counter to save PDFs up to the last filled row in a table?

Thank you very much !
Fixed part with saving files... It rests just to make If statement for not count empty rows. Actually, to stop at first empty row and to not save file named COR - .pdf

For now, I use code:

VBA Code:
Private Sub CommandButton2_Click()
If MsgBox("This action will create labels in specified folder in PRODUCTION. Are you sure?", vbYesNo) = vbNo Then Exit Sub

Dim c As Range

Set corrange = Worksheets("Print Packing").Range("D6:D31")
Set clirange = Worksheets("Print Packing").Range("O6:O31")
Set ocrange = Worksheets("Print Packing").Range("P6:P31")
Set addressrange = Worksheets("Print Packing").Range("Q6:Q31")
Set addressrange1 = Worksheets("Print Packing").Range("R6:R31")
Set addressrange2 = Worksheets("Print Packing").Range("S6:S31")
Set addressrange3 = Worksheets("Print Packing").Range("T6:T31")
Set icoderange = Worksheets("Print Packing").Range("E6:E31")
Set ccoderange = Worksheets("Print Packing").Range("U6:U31")
Set descrangei = Worksheets("Print Packing").Range("F6:F31")
Set descranges = Worksheets("Print Packing").Range("V6:V31")
Set descrangee = Worksheets("Print Packing").Range("W6:W31")
Set qtyrange = Worksheets("Print Packing").Range("I6:I31")
Set wgtrange = Worksheets("Print Packing").Range("N6:N31")

For Each c In [Table8[ID]]
    If Not IsEmpty(Range("A6:A31").Value) Then
    With Sheets("LABEL")
        .[B3] = Intersect(c.EntireRow, corrange)
        .[D3] = Intersect(c.EntireRow, clirange)
        .[B4] = Intersect(c.EntireRow, ocrange)
        .[A6] = Intersect(c.EntireRow, addressrange)
        .[A7] = Intersect(c.EntireRow, addressrange1)
        .[A8] = Intersect(c.EntireRow, addressrange2)
        .[A9] = Intersect(c.EntireRow, addressrange3)
        .[A11] = Intersect(c.EntireRow, icoderange)
        .[A12] = Intersect(c.EntireRow, ccoderange)
        .[A13] = Intersect(c.EntireRow, descrangei)
        .[A14] = Intersect(c.EntireRow, descranges)
        .[A15] = Intersect(c.EntireRow, descrangee)
        .[C16] = Intersect(c.EntireRow, qtyrange)
        .[C18] = Intersect(c.EntireRow, wgtrange)
    End With
    ThisWorkbook.Worksheets("LABEL").ExportAsFixedFormat Type:=xlTypePDF, FileName:="C:\Users\drag1c\Desktop\New folder\" & "COR " & Worksheets("LABEL").Range("B3") & " - " & Worksheets("LABEL").Range("A11").Value & ".pdf"
    End If
    Next
    
aFile = "C:\Users\drag1c\Desktop\New folder\" & "COR  - " & ".pdf"
Kill aFile
    
End Sub

But IF statement does not work and aFile is to delete file which is wrong.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,930
Messages
5,639,047
Members
417,066
Latest member
rhenman

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