日常开单送货VBA模块

最新推荐文章于 2022-09-14 00:50:29 发布

品尚公益团队

最新推荐文章于 2022-09-14 00:50:29 发布

阅读量928

点赞数

文章标签： vba

本文链接：https://blog.csdn.net/u010719791/article/details/124459254

版权

合并数据

Sub 按钮1_Click()
送货单开单.Show
End Sub

Public Sub hebing()
Dim k%
Dim sh As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
Filename = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
If Filename <> False Then
Debug.Print Filename
MP = Filename
'Name = "安智-送货单12.18"
'MP = "E:\杭实\运营数据\开单电子台账\" & Name & ".xlsx" '工作簿路径
 Set Wb = Workbooks.Open(MP)
 
 '清空数据1
last_row_clear = ThisWorkbook.Sheets("送货单").Cells(Rows.Count, "k").End(xlUp).Row '最后一行位置
' Debug.Print "行数" & last_row_clear
 ThisWorkbook.Sheets("送货单").Rows("2:" & last_row_clear).Delete
For Each sh In Wb.Worksheets
    If Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "模板" Then
    Debug.Print sh.Name
       lr = sh.Cells(Rows.Count, "B").End(xlUp).Row '获取最后一行
       last_row = ThisWorkbook.Sheets("送货单").Cells(Rows.Count, "y").End(xlUp).Row
            '获取行数
            Set rngs = sh.Range("B11:B" & lr) '确认列
            For Each Rng In rngs
            If Rng = "" Then rs = Rng.Row: GoTo 100 '获取空格行号位置
            Debug.Print rs
            Next
100:
                    sh.Range("B12:H" & rs).Copy
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "Q").PasteSpecial Paste:=xlPasteValues '复制数据
                    wn = Wb.ActiveSheet.Name '获取表名
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "B").Resize(rs - 12, 1) = sh.Range("C4") '写入仓库编号
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "C").Resize(rs - 12, 1) = sh.Range("E4") '写入发货日
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "D").Resize(rs - 12, 1) = sh.Range("G4") '写入开单日期
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "E").Resize(rs - 12, 1) = sh.Range("i4") '写入送货单号
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "F").Resize(rs - 12, 1) = sh.Range("C5") '计划单号
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "G").Resize(rs - 12, 1) = sh.Range("C6") '项目名称
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "H").Resize(rs - 12, 1) = sh.Range("G6") '我司联系人
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "I").Resize(rs - 12, 1) = sh.Range("C7") '客户单位
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "J").Resize(rs - 12, 1) = sh.Range("G7") '客户签收人
                     ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "K").Resize(rs - 12, 1) = sh.Range("C8") '收货地址
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "l").Resize(rs - 12, 1) = sh.Range("G8") '运输车号
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "M").Resize(rs - 12, 1) = sh.Range("C9") '司机姓名
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "n").Resize(rs - 12, 1) = sh.Range("G9") '联系电话
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "O").Resize(rs - 12, 1) = sh.Range("C10") '使用区域
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "p").Resize(rs - 12, 1) = sh.Range("G10") '项目签收特别要求
                    
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "y").Resize(rs - 12, 1) = sh.Name '写入表格名称
                 
                    sh.Range("A:L").RowHeight = 12 '行高
                    sh.Range("C:C").ColumnWidth = 5 '列宽
                    Wbn = Wbn & Chr(13) & Wb.Name
        Else
        
        End If
Next
'aFile = Split(Filename, "\")
'sfilename = aFile(UBound(aFile))
MsgBox "已汇总完成", vbOKOnly, "提示"
Else
MsgBox "未选择文件夹"
End If

ThisWorkbook.Worksheets("送货单").Activate
Wb.Close False '关闭工作簿
End Sub

开单

Public Sub 合并送货单数据()
Dim k%
Dim sh As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
Filename = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
If Filename <> False Then
Debug.Print Filename
MP = Filename
'Name = "安智-送货单12.18"
'MP = "E:\杭实\运营数据\开单电子台账\" & Name & ".xlsx" '工作簿路径
 Set Wb = Workbooks.Open(MP)
 
 '清空数据1
last_row_clear = ThisWorkbook.Sheets("送货单").Cells(Rows.Count, "k").End(xlUp).Row '最后一行位置
' Debug.Print "行数" & last_row_clear
 ThisWorkbook.Sheets("送货单").Rows("2:" & last_row_clear).Delete
For Each sh In Wb.Worksheets
    If Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "模板" Then
    Debug.Print sh.Name
       lr = sh.Cells(Rows.Count, "B").End(xlUp).Row '获取最后一行
       last_row = ThisWorkbook.Sheets("送货单").Cells(Rows.Count, "y").End(xlUp).Row
            '获取行数
            Set rngs = sh.Range("B11:B" & lr) '确认列
            For Each Rng In rngs
            If Rng = "" Then rs = Rng.Row: GoTo 100 '获取空格行号位置
            Debug.Print rs
            Next
100:
                    sh.Range("B12:H" & rs).Copy
                    
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "Q").PasteSpecial Paste:=xlPasteValues '复制数据
                    wn = Wb.ActiveSheet.Name '获取表名
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "B").Resize(rs - 12, 1) = sh.Range("C4") '写入仓库编号
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "C").Resize(rs - 12, 1) = sh.Range("E4") '写入发货日
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "D").Resize(rs - 12, 1) = sh.Range("G4") '写入开单日期
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "E").Resize(rs - 12, 1) = sh.Range("i4") '写入送货单号
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "F").Resize(rs - 12, 1) = sh.Range("C5") '计划单号
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "G").Resize(rs - 12, 1) = sh.Range("C6") '项目名称
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "H").Resize(rs - 12, 1) = sh.Range("G6") '我司联系人
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "I").Resize(rs - 12, 1) = sh.Range("C7") '客户单位
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "J").Resize(rs - 12, 1) = sh.Range("G7") '客户签收人
                     ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "K").Resize(rs - 12, 1) = sh.Range("C8") '收货地址
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "l").Resize(rs - 12, 1) = sh.Range("G8") '运输车号
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "M").Resize(rs - 12, 1) = sh.Range("C9") '司机姓名
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "n").Resize(rs - 12, 1) = sh.Range("G9") '联系电话
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "O").Resize(rs - 12, 1) = sh.Range("C10") '使用区域
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "p").Resize(rs - 12, 1) = sh.Range("G10") '项目签收特别要求
                    
                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "y").Resize(rs - 12, 1) = sh.Name '写入表格名称
                 
                    sh.Range("A:L").RowHeight = 12 '行高
                    sh.Range("C:C").ColumnWidth = 5 '列宽
                    Wbn = Wbn & Chr(13) & Wb.Name
        Else
        
        End If
Next
'aFile = Split(Filename, "\")
'sfilename = aFile(UBound(aFile))
Else
MsgBox "未选择文件夹"
End If

Wb.Close False '关闭工作簿
End Sub
Public Sub 测试()
'On Error Resume Next
'Dim rs1, rs
Application.ScreenUpdating = False
fname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
If fname <> False Then
    MP = fname
    Set Wb = Workbooks.Open(MP) '打开文件
    For Each sh In Wb.Worksheets
        If Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "模板" Then
                sname = sh.Name
                Set ws = ThisWorkbook.Worksheets(sname)
                    If ws Is Nothing Then
                         '新建工作表
                          ThisWorkbook.Sheets.Add after:=Sheets(ThisWorkbook.Worksheets.Count)
                          ThisWorkbook.Sheets(ThisWorkbook.Worksheets.Count).Name = sname
                      '复制数据
                        Wb.Sheets(sh.Name).Range("A:K").Copy 'UsedRange.Copy
                        ThisWorkbook.Worksheets(sname).Paste 'PasteSpecial Paste:=xlPasteValues '复制数据
                        ThisWorkbook.Worksheets(sname).Range("A:j").RowHeight = 23 '行高
                        rs = rs + 1 '统计表格述
                    Else
                            MsgBox "新增错误，表名已存在", vbOKOnly, "提示"
                            GoTo 100:
'                            rs1 = rs1 + 1
                    End If
            End If
100:
    Next sh
End If
'    If rs1 >= 1 Then
'    MsgBox "同步完成|共计" & rs & "个开单表", vbOKOnly, "提示"
'    Else
'    MsgBox "同步完成|共计" & rs - 1 & "个开单表", vbOKOnly, "提示"
'    End If
MsgBox "同步完成|共计" & rs - 1 & "个开单表", vbOKOnly, "提示"
ThisWorkbook.Worksheets("开单").Activate
Application.ScreenUpdating = True
Wb.Close False '关闭工作簿
End Sub

并到一张excel

Sub 合并目录所有工作簿全部工作表()
On Error Resume Next
Dim MP, MN, AW, Wbn, wn
Dim Wb As Workbook
Dim i, a, b, d, c, e, last_row, ni
Application.ScreenUpdating = False
'MP = ActiveWorkbook.Path
MP = "E:\杭实\汇报\公司汇报\资料\物联网1-10月工作时长\物联网1-10月工作时长" '工作簿路径
MN = Dir(MP & "\" & "*.xls") '工作簿路径
Set Newbook = Workbooks.Add
AW = ActiveWorkbook.Name
Num = 0
ni = 0
e = 3 '标题栏数量
Do While MN <> ""
    If MN <> AW Then
    ni = ni + 1 '判断导入表的顺序
    Debug.Print "导入第" & ni & "表"
    Set Wb = Workbooks.Open(MP & "\" & MN)
    a = a + 1
    '工作簿判断
    'With Workbooks(1).ActiveSheet
   With Newbook.Sheets("Sheet1") 'Workbooks(1).Sheets("Sheet4")
'        For i = 1 To Sheets.Count
'            If Sheets(i).Range("a1") <> "" Then
                'Wb.Sheets(i).Range("a4").Resize(1, Sheets(i).UsedRange.Columns.Count).Copy .Cells(1, 1)
                d = Wb.Sheets(1).UsedRange.Columns.Count '判断列数
                c = Wb.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row  'Wb.Sheets(1).UsedRange.Rows.Count - 1 '判断行数
                Debug.Print Wb.Sheets(1).Name&; "单表最后一行" & c
                
                  'Wb.Sheets(i).Range("a2).Resize(c, d).Copy .Cells(.Range("a1048576").End(xlUp).Row + 1, 1)
                last_row = .Cells(Rows.Count, 1).End(xlUp).Row '.Range("a1048576").End(xlUp).Row + 1 '最后一行位置
                Debug.Print "终表最后一行" & last_row
'                If ni = 1 Then
'                    Wb.Sheets(1).Range("a1:Y4").Copy .Cells(1, 1) '复制数据
'                    Wb.Sheets(1).Range("a5:Y" & c).Copy .Cells(4, 1) '复制数据
'                    Else
                    Wb.Sheets(1).Range("a1:H" & c).Copy .Cells(last_row + 1, 1) '复制数据
'                End If
'                Wb.Sheets(1).Range("a3:Y" & c).Copy .Cells(1, 1) '复制到第一列
                wn = Wb.Sheets(1).Name
                .Cells(4, "K") = "表名"
                .Cells(e + 1, "K").Resize(c - 2, 1) = MN & wn
                e = e + c '累计行数
                .Range("A:K").RowHeight = 12
                .Range("C:C").ColumnWidth = 35
                '.Cells(e + 1, "Z").Resize(c, 1) = MN & wn
'            End If
'        Next
        Wbn = Wbn & Chr(13) & Wb.Name
        Wb.Close False
        
    End With
    End If
    MN = Dir
Loop
Newbook.SaveAs Filename:=MP & "\" & "考勤数据.xlsx"
Range("a1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"
End Sub

工作簿操作‘

Sub 合并目录所有工作簿全部工作表()
On Error Resume Next
Dim MP, MN, AW, Wbn, wn
Dim Wb As Workbook
Dim i, a, b, d, c, e, last_row, ni
Application.ScreenUpdating = False
'MP = ActiveWorkbook.Path
MP = "E:\杭实\汇报\公司汇报\资料\物联网1-10月工作时长\物联网1-10月工作时长" '工作簿路径
MN = Dir(MP & "\" & "*.xlsx") '工作簿路径
Set Newbook = Workbooks.Add
AW = ActiveWorkbook.Name
Num = 0
ni = 0
e = 3 '标题栏数量
Do While MN <> ""
    If MN <> AW Then
    ni = ni + 1 '判断导入表的顺序
    Debug.Print "导入第" & ni & "表"
    Set Wb = Workbooks.Open(MP & "\" & MN)
    a = a + 1
    '工作簿判断
    'With Workbooks(1).ActiveSheet
'    Newbook.Sheets.Add After:=Newbook.Sheets(Newbook.Sheets.Count) '新建工作表
    Newbook.Sheets.Add.Name = ActiveWorkbook.Name & Wb.ActiveSheet.Name
'   With Newbook.Sheets("Sheet1") 'Workbooks(1).Sheets("Sheet4")
 
   With Newbook.ActiveSheet
   
                d = Wb.ActiveSheet.UsedRange.Columns.Count '判断列数
                c = Wb.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row  'Wb.Sheets(1).UsedRange.Rows.Count - 1 '判断行数
                Debug.Print Wb.Sheets(1).Name&; "单表最后一行" & c
                
                last_row = .Cells(Rows.Count, 1).End(xlUp).Row '.Range("a1048576").End(xlUp).Row + 1 '最后一行位置
                Debug.Print "终表最后一行" & last_row
 
                Wb.ActiveSheet.Range("a1:BP" & c).Copy .Cells(last_row + 1, 1) '复制数据
                wn = Wb.ActiveSheet.Name
                .Cells(4, "Z") = "表名"
                .Cells(e + 1, "Z").Resize(c - 2, 1) = MN & wn
                e = e + c '累计行数
                 .Range("A:L").RowHeight = 12 '行高
                 
                .Range("C:C").ColumnWidth = 35 '列宽
        Wbn = Wbn & Chr(13) & Wb.Name
        Wb.Close False
    End With
    
 
End If
MN = Dir
Loop
Newbook.SaveAs Filename:=MP & "\" & "进出库汇总3.xlsx"
Range("a1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"
End Sub

’遍历工作簿

Sub Ma()
mypath = "E:\杭实\财务\1-9月\"
myfile = Dir(mypath, vbDirectory)
a = 1
Do While myfile <> ""
If myfile <> "." And myfile <> ".." Then
Sheets("Sheet18").Cells(a, 1) = myfile
a = a + 1
myfile = Dir
Else
myfile = Dir
End If
Loop
End Sub

筛选模块


Public Sub 进出库筛选()
Dim k%
'On Error Resume Next
Application.ScreenUpdating = False
'MP = ActiveWorkbook.Path
Name = "（安智）杭实物联网进出库汇总表 总"
MP = "C:\Users\HONORS\Desktop\" & Name & ".xlsx" '工作簿路径
'MN = Dir(MP & "\" & "*.xlsx") '工作簿路径
' Set Wb = Workbooks.Open(MP & "\" & MN)
 Set Wb = Workbooks.Open(MP)
'-----------
' For i = 1 To Wb.Sheets.Count
'    'Cells(i, 1) = Sheets(i).Name
'    Debug.Print Wb.Sheets(i).Name '获取表名
'Next
 '-----------
stockName = Array("总账（镇江库）", "总账（衢州库）", "总账（诸暨库）", "总账（昆山库）", "总账（泉州库）", "总账（武汉库）", "总账（泗阳库）", "总账（全椒库）")
For i = 0 To UBound(stockName)
Debug.Print i
'        If i = 0 Then
'             Wb.ActiveSheet.Range("a1:Y3").Copy ThisWorkbook.Sheets("测试").Cells(1, 1)  '复制标题
'             ThisWorkbook.Sheets("测试").Cells(1, 1).Resize(3, 1) = 1
'        End If
    With Wb.Sheets(stockName(i))
          Wb.Sheets(stockName(i)).Activate '当前工作表激活
            lr = .Cells(Rows.Count, "A").End(xlUp).Row '获取最后一行
            Set rngs = .Range("A1:A" & lr) '确认列
            For Each Rng In rngs
    '            Debug.Print Rng.Value
                    If Rng.Value Like "2021/11/28" Then
                        k = k + 1 '记录条目
                        Debug.Print "条目" & k & "：" & Rng.Value & ActiveSheet.Name '输出当前工作表内容
                        last_row = ThisWorkbook.Sheets("进出库").Cells(Rows.Count, 1).End(xlUp).Row '最后一行位置
    '                       n = n + 1 '判断行数
                            ThisWorkbook.Sheets("进出库").Cells(last_row, "a").Resize(2, 25) = Rng.EntireRow.Range("a1:y1").Value  '获取对应条目内容
                            ThisWorkbook.Sheets("进出库").Cells(last_row, "z").Value = ActiveSheet.Name  '写入表格名称
                    End If
            Next
        End With
Next
    ThisWorkbook.Sheets("进出库").Range("A:L").RowHeight = 15 '行高
'    ThisWorkbook.Sheets("进出库").Range("C:C").ColumnWidth = 35 '列宽
   Wb.Close False '关闭工作簿

End Sub
Public Sub 运输筛选()
Dim k%
On Error Resume Next
Application.ScreenUpdating = False
'MP = ActiveWorkbook.Path
Name = "脚手架运输台账（热联&安智）12.1"
MP = "C:\Users\HONORS\Desktop\" & Name & ".xlsx" '工作簿路径
'MN = Dir(MP & "\" & "*.xlsx") '工作簿路径
' Set Wb = Workbooks.Open(MP & "\" & MN)
 Set Wb = Workbooks.Open(MP)
'-----------
' For i = 1 To Wb.Sheets.Count
'    'Cells(i, 1) = Sheets(i).Name
'    Debug.Print Wb.Sheets(i).Name '获取表名
'Next
 '-----------
stockName = Array("热联")
'For i = 0 To UBound(stockName)
Debug.Print i
'        If i = 0 Then接下来的货量，货量预计；
    With Wb.ActiveSheet 'Wb.Sheets(stockName(0))
'          Wb.Sheets(stockName(0)).Activate '当前工作表激活
            lr = .Cells(Rows.Count, "A").End(xlUp).Row '获取最后一行
            Set rngs = .Range("D1:D" & lr) '确认列
            For Each Rng In rngs
    '            Debug.Print Rng.Value
                    If Rng.Value Like "2021/11/29" Then
                        k = k + 1 '记录条目
                        Debug.Print "条目" & k & "：" & Rng.Value & ActiveSheet.Name '输出当前工作表内容
                        last_row = ThisWorkbook.Sheets("运输").Cells(Rows.Count, 1).End(xlUp).Row '最后一行位置
    '                       n = n + 1 '判断行数
                            ThisWorkbook.Sheets("运输").Cells(last_row, "a").Resize(2, 147) = Rng.EntireRow.Range("a1:EQ1").Value  '获取对应条目内容
                            ThisWorkbook.Sheets("运输").Cells(last_row, "ER").Value = ActiveSheet.Name  '写入表格名称
                    
                    End If
            Next
        End With
         ThisWorkbook.Sheets("运输").Range("A:L").RowHeight = 15 '行高
'         ThisWorkbook.Sheets("运输").Range("C:C").ColumnWidth = 35 '列宽
         
'Next

   Wb.Close False '关闭工作簿

End Sub