Generate a label stickers with macros without using mail merge.

J

jhonty4

Board Regular
Joined
May 16, 2016
Messages
85
Hi, I have an excel sheet Containing columns "Article name" , "Color", "Size", "Style", "Location" & "Article code" in range A6:F6 respectively. This excel is being generated by an ERP system. Now what we want to do is pick rows from this sheet & add a new sheet with the cell dimension in the size of 2"*4". I want the macro to just copy the cells from column A:F and paste in the single cell in the newly added sheet. Note that the header is not required and a line break is required after every column field is pasted in the new cell.
PS- I have tried avery label generator but since we have to deal with a lot of excels like this drag & drop process is time taking.
TIA
 
Sort by date Sort by votes
jhonty4,

You might consider the following...

Code: 
Sub AveryLabels5163()

''''    Print onto Avery Compatible 5163 labels (2" x 4")
''''    Caveat:  You may need to adjust row height/column width and/or margins to fit your labels

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim LastRow As Long, i As Long, j As Long, NoCols As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Filtur As String
Dim prtArea As Range

Set ws1 = ActiveSheet
Set ws2 = Sheets.Add(after:=Worksheets(Worksheets.Count))
LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
Filtur = InputBox("Please Enter Filter Criterion")

''''    Filter and copy data to new sheet
On Error GoTo errHandler:
With ws1
    .AutoFilterMode = False
    .Range("A1:G1").AutoFilter
    .Range("A1:G1").AutoFilter Field:=1, Criteria1:=Filtur
    .Range("B2:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy ws2.Range("B1")
    .AutoFilterMode = False
End With

''''    Concatenate data to Column A
LastRow = ws2.Cells(Rows.Count, "B").End(xlUp).Row
With ws2
    For i = 1 To LastRow
        .Cells(i, 1) = .Cells(i, 2) & vbCrLf & .Cells(i, 3) & vbCrLf & _
                       .Cells(i, 4) & vbCrLf & .Cells(i, 5) & vbCrLf & _
                       .Cells(i, 6) & vbCrLf & .Cells(i, 7)
        .Cells(i, 1).Value = Cells(i, 1).Value
    Next i
    Columns("B:G").Delete
End With

''''    Resize to two across
j = 1
NoCols = 2
For i = 1 To LastRow Step NoCols
    ws2.Cells(j, "A").Resize(1, NoCols).Value = _
    Application.Transpose(ws2.Cells(i, "A").Resize(NoCols, 1))
    j = j + 1
Next
Range(ws2.Cells(j, "A"), ws2.Cells(LastRow, "A")).Clear
LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
Set prtArea = ws2.Range("A1:C" & LastRow)

''''    Format cells
With ws2.Cells
    .RowHeight = 144 'Adjust as necessary
    .ColumnWidth = 54.57 'Adjust as necessary
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
End With

''''    Set Print Settings
Application.PrintCommunication = False
With ws2.PageSetup
    .LeftMargin = Application.InchesToPoints(0.01) 'Adjust as necessary
    .RightMargin = Application.InchesToPoints(0.01) 'Adjust as necessary
    .TopMargin = Application.InchesToPoints(0.5) 'Adjust as necessary
    .BottomMargin = Application.InchesToPoints(0.5) 'Adjust as necessary
    .Orientation = xlPortrait
    .PaperSize = xlPaperLetter
    .FitToPagesWide = 1
    .FitToPagesTall = False
    .PrintArea = prtArea.Address
End With
Application.PrintCommunication = True

Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub

errHandler:
    ws1.AutoFilterMode = False
    ws2.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Sorry, your filter criterion did not find a match." & vbCrLf & _
        "Please try again."
End Sub


Notes:
Insert a column into Column A and mark each row (for example, with an "x") that you want to label.
Run the macro; you will be prompted to enter the filter criteria (in this example "x").
The macro will add a new sheet in label format.
You may need to adjust the row height and/or column width, as well as the margins in your print settings. See the "Adjust as necessary" comments in the code.
You may also need to manually adjust the right page break to two columns while in the Page Break View.

Cheers,

tonyyy
 
Last edited:
Upvote 0
That is brilliant Tony.Thanks. Can you please also help adjust the setting to print into avery compatible 4014(1 7/16 * 4) label because the printer available to us only prints roll form labels.

Thanks again. :)
 
Upvote 0
Code: 
Sub AveryLabels4014()

''''    Print onto Avery Compatible 4014 labels (1 7/16" x 4")
''''    Caveat:  You may need to adjust row height/column width and/or margins to fit your labels

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim LastRow As Long, i As Long, j As Long, NoCols As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Filtur As String
Dim prtArea As Range

Set ws1 = ActiveSheet
Set ws2 = Sheets.Add(after:=Worksheets(Worksheets.Count))
LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
Filtur = InputBox("Please Enter Filter Criterion")

''''    Filter and copy data to new sheet
On Error GoTo errHandler:
With ws1
    .AutoFilterMode = False
    .Range("A1:G1").AutoFilter
    .Range("A1:G1").AutoFilter Field:=1, Criteria1:=Filtur
    .Range("B2:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy ws2.Range("B1")
    .AutoFilterMode = False
End With

''''    Concatenate data to Column A
LastRow = ws2.Cells(Rows.Count, "B").End(xlUp).Row
With ws2
    For i = 1 To LastRow
        .Cells(i, 1) = .Cells(i, 2) & vbCrLf & .Cells(i, 3) & vbCrLf & _
                       .Cells(i, 4) & vbCrLf & .Cells(i, 5) & vbCrLf & _
                       .Cells(i, 6) & vbCrLf & .Cells(i, 7)
        .Cells(i, 1).Value = Cells(i, 1).Value
    Next i
    Columns("B:G").Delete
End With

''''    Resize to one across
j = 1
NoCols = 1
For i = 1 To LastRow Step NoCols
    ws2.Cells(j, "A").Resize(1, NoCols).Value = _
    Application.Transpose(ws2.Cells(i, "A").Resize(NoCols, 1))
    j = j + 1
Next
Range(ws2.Cells(j, "A"), ws2.Cells(LastRow, "A")).Clear
LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
Set prtArea = ws2.Range("A1:C" & LastRow)

''''    Format cells
With ws2.Cells
    .RowHeight = 103.5 'Adjust as necessary
    .ColumnWidth = 54.57 'Adjust as necessary
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
End With

''''    Set Print Settings
Application.PrintCommunication = False
With ws2.PageSetup
    .LeftMargin = Application.InchesToPoints(0.01) 'Adjust as necessary
    .RightMargin = Application.InchesToPoints(0.01) 'Adjust as necessary
    .TopMargin = Application.InchesToPoints(0#)  'Adjust as necessary
    .BottomMargin = Application.InchesToPoints(0#)  'Adjust as necessary
    .Orientation = xlPortrait
    .PaperSize = xlPaperLetter 'adjust to match your printer type
    .FitToPagesWide = 1
    .FitToPagesTall = False
    .PrintArea = prtArea.Address
End With
Application.PrintCommunication = True

Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub

errHandler:
    ws1.AutoFilterMode = False
    ws2.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Sorry, your filter criterion did not find a match." & vbCrLf & _
        "Please try again."
End Sub

You'll need to adjust the .PaperSize in the "Set Print Settings" portion of the code.
 
Upvote 0
Just one more thing Tony. I have made a little changes to the code to apply filter to row 6. Now if I am writing "X" in the filtur criteria for only the first row the label is not getting generated. when I am writing "X" for other rows as well the first row(row 7) label is getting generated along with the rest. Any solution to this? . The code that i am using is this
Code: 
Sub AveryLabels4014()

''''    Print onto Avery Compatible 4014 labels (1 7/16" x 4")
''''    Caveat:  You may need to adjust row height/column width and/or margins to fit your labels


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim LastRow As Long, i As Long, j As Long, NoCols As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Filtur As String
Dim prtArea As Range


Set ws1 = ActiveSheet
Set ws2 = Sheets.Add(after:=Worksheets(Worksheets.Count))
LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
Filtur = InputBox("Please Enter Filter Criterion")


''''    Filter and copy data to new sheet
On Error GoTo errHandler:
With ws1
    .AutoFilterMode = False
    .Range("A6:G6").AutoFilter
    .Range("A6:G6").AutoFilter Field:=1, Criteria1:=Filtur
    .Range("B7:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy ws2.Range("B1")
    .AutoFilterMode = False
End With


''''    Concatenate data to Column A
LastRow = ws2.Cells(Rows.Count, "B").End(xlUp).Row
With ws2
    For i = 1 To LastRow
        .Cells(i, 1) = .Cells(i, 2) & vbCrLf & .Cells(i, 3) & vbCrLf & _
                       .Cells(i, 4) & vbCrLf & .Cells(i, 5) & vbCrLf & _
                       .Cells(i, 6) & vbCrLf & .Cells(i, 7)
        .Cells(i, 1).Value = Cells(i, 1).Value
    Next i
    Columns("B:G").Delete
End With


''''Resize to one across
j = 1
NoCols = 1
For i = 1 To LastRow Step NoCols
    ws2.Cells(j, "A").Resize(1, NoCols).Value = _
    Application.Transpose(ws2.Cells(i, "A").Resize(NoCols, 1))
    j = j + 1
Next
Range(ws2.Cells(j, "A"), ws2.Cells(LastRow, "A")).Clear
LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
Set prtArea = ws2.Range("A1:C" & LastRow)


''''    Format cells
With ws2.Cells
    .RowHeight = 103.5 'Adjust as necessary
    .ColumnWidth = 54.57 'Adjust as necessary
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
End With


''''    Set Print Settings
Application.PrintCommunication = False
With ws2.PageSetup
    .LeftMargin = Application.InchesToPoints(0.01) 'Adjust as necessary
    .RightMargin = Application.InchesToPoints(0.01) 'Adjust as necessary
    .TopMargin = Application.InchesToPoints(0#)  'Adjust as necessary
    .BottomMargin = Application.InchesToPoints(0#)  'Adjust as necessary
    .Orientation = xlPortrait
    .PaperSize = xlPaperLetter 'adjust to match your printer type
    .FitToPagesWide = 1
    .FitToPagesTall = False
    .PrintArea = prtArea.Address
End With
Application.PrintCommunication = True


Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub


errHandler:
    ws1.AutoFilterMode = False
    ws2.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Sorry, your filter criterion did not find a match." & vbCrLf & _
        "Please try again."
End Sub
 
Upvote 0
Code: 
Sub AveryLabels4014Row7()

''''    Print onto Avery Compatible 4014 labels (1 7/16" x 4")
''''    Caveat:  You may need to adjust row height/column width and/or margins to fit your labels


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim LastRow As Long, i As Long, j As Long, NoCols As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Filtur As String
Dim prtArea As Range


Set ws1 = ActiveSheet
Set ws2 = Sheets.Add(after:=Worksheets(Worksheets.Count))
LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
Filtur = InputBox("Please Enter Filter Criterion")


''''    Filter and copy data to new sheet
On Error GoTo errHandler:
With ws1
    .AutoFilterMode = False
    .Range("A6:G6").AutoFilter
    .Range("A6:G6").AutoFilter Field:=1, Criteria1:=Filtur
    .Range("B7:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy ws2.Range("B1")
    .AutoFilterMode = False
End With


''''    Concatenate data to Column A
LastRow = ws2.Cells(Rows.Count, "B").End(xlUp).Row + 1
With ws2
    For i = 1 To LastRow
        .Cells(i, 1) = .Cells(i, 2) & vbCrLf & .Cells(i, 3) & vbCrLf & _
                       .Cells(i, 4) & vbCrLf & .Cells(i, 5) & vbCrLf & _
                       .Cells(i, 6) & vbCrLf & .Cells(i, 7)
        .Cells(i, 1).Value = Cells(i, 1).Value
    Next i
    Columns("B:G").Delete
End With


''''Resize to one across
j = 1
NoCols = 1
For i = 1 To LastRow Step NoCols
    ws2.Cells(j, "A").Resize(1, NoCols).Value = _
    Application.Transpose(ws2.Cells(i, "A").Resize(NoCols, 1))
    j = j + 1
Next
Range(ws2.Cells(j + 1, "A"), ws2.Cells(LastRow, "A")).Clear
LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
Set prtArea = ws2.Range("A1:C" & LastRow)


''''    Format cells
With ws2.Cells
    .RowHeight = 103.5 'Adjust as necessary
    .ColumnWidth = 54.57 'Adjust as necessary
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
End With


''''    Set Print Settings
Application.PrintCommunication = False
With ws2.PageSetup
    .LeftMargin = Application.InchesToPoints(0.01) 'Adjust as necessary
    .RightMargin = Application.InchesToPoints(0.01) 'Adjust as necessary
    .TopMargin = Application.InchesToPoints(0#)  'Adjust as necessary
    .BottomMargin = Application.InchesToPoints(0#)  'Adjust as necessary
    .Orientation = xlPortrait
    .PaperSize = xlPaperLetter 'adjust to match your printer type
    .FitToPagesWide = 1
    .FitToPagesTall = False
    .PrintArea = prtArea.Address
End With
Application.PrintCommunication = True


Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub


errHandler:
    ws1.AutoFilterMode = False
    ws2.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Sorry, your filter criterion did not find a match." & vbCrLf & _
        "Please try again."
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Dynamic Email Generation via VBA - Extracting & Sending Data Across Multiple Sheets
Replies
0
Views
175
Jess1234556
J
G
  • Question Question
VBA code to merge two near identical workbooks
Replies
1
Views
212
akmatz
A
D
  • Question Question
Generating Reports in Word Using Data in Excel
Replies
1
Views
612
Dan_W
D
P
  • Question Question
Hoping to get help with a Macro!
Replies
0
Views
327
PEM000
P
J
  • Question Question
VBA or formula to move data in last used column to column A
Replies
5
Views
437
Peter_SSs
Peter_SSs

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