批量生成标签并转换为PDF文件

Public row_ab
Public row_cd
Public ar_title
Public r_new_sht
Public sname
'Public k
'Public k1

Private Sub deleteSheet()
Application.DisplayAlerts = False
For Each sht In Sheets
If IsNumeric(sht.Name) Then
sht.Delete
End If
Next sht
Application.DisplayAlerts = True
End Sub
Private Sub mCopySheet() '复制表格
With Sheets("src")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
End With
Excel.Application.ScreenUpdating = False
For x = 1 To lastRow
Sheet5.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "转换后"
ActiveSheet.Name = Format(x, "00")
Next
Excel.Application.ScreenUpdating = True
End Sub

Private Sub clear()
With Sheets("Sheet1")
.Cells.ClearContents
End With

End Sub

Private Sub setFont()
With Sheets("Sheet1")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For x = 3 To lastRow Step 4
.Cells(x, 2).Font.Size = 20
.Cells(x, 5).Font.Size = 20
Next
End With
End Sub
Sub main() '主过程
Call deleteSheet
Call mCopySheet
'clear
'n = 0
sname = 1
row_ab = 0
row_cd = 0
'ar_title = Array("品名:", "规格:", "厂家:")
With Sheets("src")
ar = .Range("a1").CurrentRegion
For x = 2 To UBound(ar)
ar_row = Application.Index(ar, x, 0)
If x Mod 2 = 0 Then
writeByRowAtAB (ar_row)
Else
writeByRowAtCD (ar_row)
End If
Next
.Cells.EntireColumn.AutoFit
End With
MsgBox "标签已生成,下面即将生成PDF格式文件!"
End Sub
Private Sub writeByRowAtAB(ar)
If row_ab = 30 Then sname = sname + 1: row_ab = 0: row_cd = 0
sname = Format(sname, "00")
With Sheets(sname)
.Select
For x = 1 To UBound(ar)
k = k + 1
' .Cells(k + row_ab, 1) = ar_title(x - 1)
.Cells(k + row_ab, 2) = ar(x)
Next
row_ab = .Cells(.Rows.Count, 2).End(xlUp).Row + 2
' row_ab = k + 2
End With
'End If
End Sub
Private Sub writeByRowAtCD(ar)
With Sheets(sname)
.Select
For x = 1 To UBound(ar)
k1 = k1 + 1
' .Cells(k + row_cd, 4) = ar_title(x - 1)
.Cells(k1 + row_cd, 6) = ar(x)

Next
row_cd = .Cells(.Rows.Count, 6).End(xlUp).Row + 2
' row_cd = k1 + 2
End With
'End If
End Sub

Private Sub copyShape()
ActiveSheet.Shapes.Range(Array("Rounded Rectangle 3595")).Select
Selection.Copy
With Sheets("Sheet1")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For x = 5 To lastRow Step 4
' Range("D1").Select
.Cells(x, 1).Select
ActiveSheet.Paste
Next
For x = 1 To lastRow Step 4
' Range("D1").Select
.Cells(x, 4).Select
ActiveSheet.Paste
Next
End With

End Sub
Private Sub 宏2()
With Sheets("Sheet1")
Cells.ShrinkToFit = True
End With
End Sub

Private Sub BatchConvertWorkBookToPDF() '转换为pdf
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
Dim vrtSelectedItem As Variant
Dim wkBook As Workbook
Dim showFolder As Boolean
showFolder = False
With fDialog
.Filters.Add "Excel文件", "*.xls; *.xlsx; *.xlsm", 1
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
'如果选择了本工作簿则跳过
If InStrRev(vrtSelectedItem, ThisWorkbook.Name) = 0 Then
On Error Resume Next
Set wkBook = Application.Workbooks.Open(vrtSelectedItem, ReadOnly:=True, Password:="")
'跳过设置打开密码的工作簿
If Not wkBook Is Nothing Then
'跳过隐藏的工作簿
If Windows(wkBook.Name).Visible = True Then
For i = 1 To Sheets.Count
wkBook.Sheets(i).Select
Application.Calculation = xlManual
wkBook.Sheets(i).Unprotect
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Next
For i = 1 To Sheets.Count
If wkBook.Sheets(i).Name = "不打印" Then wkBook.Sheets(i).Delete
Next
showFolder = True
'转换开始
wkBook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Left(vrtSelectedItem, InStrRev(vrtSelectedItem, ".") - 1) & ".pdf" _
, Quality:=xlQualityMinimum, IncludeDocProperties:=False, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
wkBook.Close , savechanges = False
Else
wkBook.Close , savechanges = False
End If
End If
End If
Next vrtSelectedItem
If showFolder Then Call Shell("explorer.exe " & Left(fDialog.SelectedItems(1), _
InStrRev(fDialog.SelectedItems(1), "\")), vbMaximizedFocus)
End If
End With

Set fDialog = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

 

Sub BatchConvertWorkBookToPDF()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
Dim vrtSelectedItem As Variant
Dim wkBook As Workbook
Dim showFolder As Boolean
showFolder = False
With fDialog
.Filters.Add "Excel文件", "*.xls; *.xlsx; *.xlsm", 1
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
'如果选择了本工作簿则跳过
If InStrRev(vrtSelectedItem, ThisWorkbook.Name) = 0 Then
On Error Resume Next
Set wkBook = Application.Workbooks.Open(vrtSelectedItem, ReadOnly:=True, Password:="")
'跳过设置打开密码的工作簿
If Not wkBook Is Nothing Then
'跳过隐藏的工作簿
If Windows(wkBook.Name).Visible = True Then
For i = 1 To Sheets.Count
wkBook.Sheets(i).Select
Application.Calculation = xlManual
wkBook.Sheets(i).Unprotect
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Next
For i = 1 To Sheets.Count
If wkBook.Sheets(i).Name = "不打印" Then wkBook.Sheets(i).Delete
Next
showFolder = True
'转换开始
wkBook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Left(vrtSelectedItem, InStrRev(vrtSelectedItem, ".") - 1) & ".pdf" _
, Quality:=xlQualityMinimum, IncludeDocProperties:=False, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
wkBook.Close , savechanges = False
Else
wkBook.Close , savechanges = False
End If
End If
End If
Next vrtSelectedItem
If showFolder Then Call Shell("explorer.exe " & Left(fDialog.SelectedItems(1), _
InStrRev(fDialog.SelectedItems(1), "\")), vbMaximizedFocus)
End If
End With

Set fDialog = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub