精华内容
下载资源
问答
  • 合并Excel文件 宏代码 合并工作表 宏代码
  • Excel中VBA合并工作表

    2021-12-29 10:34:39
    合并送货单数据 Dim k% Dim sh As Worksheet On Error Resume Next Application.ScreenUpdating = False Name = "安智-送货单12.18" MP = "E:\杭实\运营数据\开单电子台账\" & Name & ".xlsx" '工作簿路径...

    时间初始化:

    ComboBox1.Text = "1"
    'Dim checi(11)
    For i = 1 To 10
    'checi(i) = "第" & i & "车"
    ComboBox1.AddItem (i)
    Next i
    '当前日期
    Nt = DateAdd("d", -2, Now)
    TextBox1.Text = Format(Nt, "yyyy/m/d")
    'ComboBox1.List = checi 'Array("A", "B", "C", "D")
    'ComboBox1.RowSource = checi 'Array("A", "B", "C", "D")
    'CommandButton1.Enabled = True
    'CommandButton2.Enabled = False
    'CommandButton3.Enabled = False
    'CommandButton4.Enabled = True
    'CommandButton5.Enabled = False
    'CommandButton6.Enabled = True
    'CommandButton7.Enabled = False
    'CommandButton8.Enabled = False
    'CommandButton9.Enabled = False
    'CommandButton10.Enabled = False
    'ComboBox1.Enabled = False

    合并送货单数据

    Private Sub CommandButton1_Click() '开单汇总
    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

    新增工作表

    Private Sub CommandButton3_Click() '新增
    'Set Newbook = Workbooks.Add
    Sname = ThisWorkbook.Sheets("开单").Range("C6").Value
    ThisWorkbook.Sheets.Add after:=Sheets(ThisWorkbook.Worksheets.Count)
    ThisWorkbook.Sheets.Add.Name = Sname
    End Sub

    判断是否重复、新增工作表

    Private Sub CommandButton3_Click() '判断是否重复、新增工作表
    On Error Resume Next
    Application.ScreenUpdating = False
    sname = ThisWorkbook.Sheets("开单").Range("C6").Value '文件名
    Dim sh As Worksheet
    '数据判断
    Danhao = ThisWorkbook.Sheets("开单").Range("I4").Value '送货单号
    '判断日期----
    pddanhao = Trim(Mid(Danhao, 3, 8)) '判断日期
    'Debug.Print pddanhao
    'Debug.Print Format(Now, "yyyymmdd")
    If pddanhao <> Format(Now, "yyyymmdd") Then
        rresponse = MsgBox("单号日期异常-非今天单据" & pddanhao & ",确认是否继续", vbOKCancel, "提示")
        If rresponse = vbOK Then
           GoTo 100:
        Else
            
            Exit Sub
        End If
    End If
    100:
    '判断继续------
    
    Xiangmu = ThisWorkbook.Sheets("开单").Range("C6").Value '项目名称
    If Danhao = "" Then MsgBox "送货单号不能为空", vbOKOnly, "提示": Exit Sub
    If Xiangmu = "" Then MsgBox "项目名称不能为空", vbOKOnly, "提示": Exit Sub
    
    
    '新增工作表判断
    For Each sh In ThisWorkbook.Worksheets
         If Trim(sh.Name) <> "开单" And Trim(sh.Name) <> "送货单" And Trim(sh.Name) <> "出库台账" And Trim(sh.Name) <> "模板" Then
                 Debug.Print sh.Name
                  If Danhao = sh.Range("i4") Then '判断送货单号是否重复
                  rresponse = MsgBox("送货单号重复", vbOKOnly, "送货单必须唯一") 'MsgBox("送货单号重复", vbYesNoCancel, "送货单必须唯一")
                  Exit Sub
                Else
                 End If
        End If
    Next
    
    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
      '复制数据
        ThisWorkbook.Sheets("开单").Range("A:K").Copy 'UsedRange.Copy
        ThisWorkbook.Worksheets(sname).Paste 'PasteSpecial Paste:=xlPasteValues '复制数据
         ThisWorkbook.Worksheets(sname).Range("E4").Copy 'UsedRange.Copy
        ThisWorkbook.Worksheets(sname).Range("E4").PasteSpecial Paste:=xlPasteValues '发货日期
         ThisWorkbook.Worksheets(sname).Range("G4").Copy 'UsedRange.Copy
        ThisWorkbook.Worksheets(sname).Range("G4").PasteSpecial Paste:=xlPasteValues '开单日期
        ThisWorkbook.Worksheets(sname).Range("A:j").RowHeight = 23 '行高
        
        
    '    ---写入进出库台账----
        kaidanlr = ThisWorkbook.Sheets("开单").Cells(Rows.Count, "B").End(xlUp).Row '计算开单最后一行
        taizhanglr = ThisWorkbook.Sheets("出库台账").Cells(Rows.Count, "i").End(xlUp).Row '计算台账最后一行
        Debug.Print kaidanlr, taizhanglr
    '    求空白单元格位置
            Set rngs = ThisWorkbook.Sheets("开单").Range("B11:B" & kaidanlr)   '确认列
            For Each Rng In rngs
            If Rng = "" Then rs = Rng.Row: GoTo 110 '获取空格行号位置
            Debug.Print rs
            Next
    110:
    '    判断单号是否重复
            Set rrngs = ThisWorkbook.Sheets("出库台账").Range("C4:C" & taizhanglr)    '确认列
            For Each Rrng In rrngs
            If Rrng = ThisWorkbook.Sheets("开单").Range("i4") Then GoTo 111:
    '        Debug.Print rs
            Next
    
        ThisWorkbook.Sheets("开单").Range("C12:C" & rs).Copy 'UsedRange.Copy
        ThisWorkbook.Worksheets("出库台账").Range("E" & taizhanglr + 1).PasteSpecial Paste:=xlPasteValues '类别
        ThisWorkbook.Sheets("开单").Range("E12:E" & rs).Copy 'UsedRange.Copy
        ThisWorkbook.Worksheets("出库台账").Range("F" & taizhanglr + 1).PasteSpecial Paste:=xlPasteValues '规格
        ThisWorkbook.Sheets("开单").Range("D12:D" & rs).Copy 'UsedRange.Copy
        ThisWorkbook.Worksheets("出库台账").Range("G" & taizhanglr + 1).PasteSpecial Paste:=xlPasteValues '规格
    
        ThisWorkbook.Sheets("出库台账").Cells(taizhanglr + 1, "A").Resize(rs - 12, 1) = ThisWorkbook.Sheets("开单").Range("E4").Value '项目签收特别要求
        ThisWorkbook.Sheets("出库台账").Cells(taizhanglr + 1, "B").Resize(rs - 12, 1) = ThisWorkbook.Sheets("开单").Range("G8").Value '车号
         ThisWorkbook.Sheets("出库台账").Cells(taizhanglr + 1, "C").Resize(rs - 12, 1) = ThisWorkbook.Sheets("开单").Range("i4").Value  '车号
          ThisWorkbook.Sheets("出库台账").Cells(taizhanglr + 1, "D").Resize(rs - 12, 1) = ThisWorkbook.Sheets("开单").Range("C5").Value '车号
        ThisWorkbook.Sheets("出库台账").Cells(taizhanglr + 1, "i").Resize(rs - 12, 1) = "出库"
        
        ThisWorkbook.Sheets("出库台账").Range("A:i").EntireColumn.AutoFit
    Else
            MsgBox "新增错误,表名已存在", vbOKOnly, "提示"
    End If
    
    
    
    
    
    
    
    111:
    Application.ScreenUpdating = True
    Application.CutCopyMode = xlCopy
    MsgBox "开单已新增", vbOKOnly, "提示"
    ThisWorkbook.Worksheets("开单").Activate
    End Sub

    同步数据

    Private Sub CommandButton4_Click() '同步数据
    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:=ThisWorkbook.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 "新增错误,表名已存在" & sname, vbOKOnly, "提示"
                                GoTo 0:
                        End If
    '                    On Error GoTo 0
    0:
                    Set ws = Nothing
                End If
    100:
        Debug.Print sh.Name
        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

    导入委托单

    Private Sub CommandButton5_Click() '导入委托单
    On Error Resume Next
    Dim Danhao()
    Dim rs As Integer
    
    fname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
    '判断文件是否存在
    If fname <> False Then
        MP = fname
    Else
        MsgBox "没有选中文件"
        Exit Sub
    End If
    MP = fname
    Set wb = Workbooks.Open(MP) '打开文件
    '复制数据
    With ThisWorkbook.Worksheets("开单")
        '车次相关信息复制
        checi = 9 + Val(ComboBox1.Value)
        .Range("i4") = Replace(wb.Sheets("发货单").Range("B" & checi).Value, Chr(10), "") '计划单号
        .Range("C5") = Replace(wb.Sheets("发货单").Range("C" & checi).Value, Chr(10), "") '计划单号
        .Range("G8") = Replace(wb.Sheets("发货单").Range("H" & checi).Value, Chr(10), "") '运输车号
        .Range("C9") = Replace(wb.Sheets("发货单").Range("D" & checi).Value, Chr(10), "") '司机姓名
        .Range("G9") = Replace(wb.Sheets("发货单").Range("F" & checi).Value, Chr(10), "") '司机电话
    '    wb.Sheets("发货单").Range("C" & checi).Copy  '计划单号
    '    .Range("C5").PasteSpecial Paste:=xlPasteValues '复制数据
        
        '通用信息复制
        .Range("C6") = Trim(wb.Sheets("发货单").Range("C6").Value) '项目名称
        .Range("G6") = Trim(wb.Sheets("发货单").Range("E6").Value) & Trim(wb.Sheets("发货单").Range("F6").Value) '我司联系人
        .Range("C8") = Trim(wb.Sheets("发货单").Range("C8").Value) '收货地址
          .Range("C7") = Trim(wb.Sheets("发货单").Range("G18").Value) '客户单位
           .Range("G7") = Trim(wb.Sheets("发货单").Range("G6").Value) '客户签收人
        
    End With
    MsgBox "导入完成", vbOKOnly, "提示"
    
    '判断有几车
     lr = wb.Sheets("发货单").Cells(Rows.Count, "B").End(xlUp).Row '获取最后一行
    Set rngs = wb.Sheets("发货单").Range("B9:B" & lr) '确认列
        For Each Rng In rngs
            If Rng = "" Then
            GoTo 100 '获取空格行号位置
        Else
            rs = rs + 1
    '            Debug.Print rs
        End If
        Next
    100:
    If rs > 2 Then MsgBox "共计" & rs - 1 & "车|已导入可忽略", vbOKOnly, "提示"
    
    
    ThisWorkbook.Worksheets("开单").Activate
    'ThisWorkbook.Worksheets("开单").Range("i4").PasteSpecial Paste:=xlPasteValues '复制数据
     wb.Close False '关闭工作簿
    End Sub

    表格初始化:

    Private Sub CommandButton6_Click() '初始化表单
    On Error Resume Next
    Dim sh As Worksheet
    Application.DisplayAlerts = False
    
    rresponse = MsgBox("是否初始化", vbOKCancel, "提示")
    If rresponse = vbOK Then
         For Each sh In ThisWorkbook.Worksheets
                If Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "开单" And Trim(sh.Name) <> "送货单" Then
                sh.Delete
                End If
        Next sh
    Else
        Exit Sub
    End If
    Application.DisplayAlerts = True
    End Sub

    combobox初始化

    Private Sub UserForm_Initialize()
    ComboBox1.Text = "第1车"
    Dim checi(11)
    For i = 1 To 10
    'checi(i) = "第" & i & "车"
    ComboBox1.AddItem ("第" & i & "车")
    Next i
    'ComboBox1.List = checi 'Array("A", "B", "C", "D")
    'ComboBox1.RowSource = checi 'Array("A", "B", "C", "D")
    End Sub

    数据备份

    Private Sub CommandButton7_Click() '数据备份
    On Error Resume Next
    Nname = Split(ActiveWorkbook.Name, ".")(0)
    Application.Dialogs(xlDialogSaveAs).Show (Nname & Format(Now, "yyyymmdd"))
    '
    'MyFileName = Application.GetSaveAsFilename(InitialFileName:=Nname & Format(Now, "yyyymmdd hhmmss") & ".xlsx", fileFilter:="excel工作簿(*.xlsx),*.xlsx", Title:="数据备份")
    'If MyFileName <> "False" Then
    'ActiveWorkbook.SaveAs Filename:=MyFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    'End If
    'Debug.Print ThisWorkbook.Path & "\" & Nname & Format(Now, "yyyymmdd hhmmss") & ".xlsx"
    
    'ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Nname & Format(Now, "yyyymmdd hhmmss") & ".xlsx"
    
    MsgBox "数据已备份", vbOKOnly, "提示"
    End Sub

    设置打印

    Private Sub CommandButton8_Click() '设置打印
    '    Range("B2:E15").Select
    '    ActiveSheet.PageSetup.PrintArea = "$B$2:$E$15"
    '    Selection.PrintOut Copies:=1, Collate:=True
    '    Range("G2:H14").Select
    '    ActiveSheet.PageSetup.PrintArea = "$G$2:$H$14"
    '    Selection.PrintOut Copies:=1, Collate:=True
    '    Range("J15:K16").Select
    '    ActiveSheet.PageSetup.PrintArea = "$J$15:$K$16"
    '    Selection.PrintOut Copies:=1, Collate:=True
    '    Range("L2:M14").Select
    
    'Application.Dialogs(xlDialogPrint).Show
    ' '---设置打印区域
     Me.Hide
    '    ActiveWindow.SelectedSheets.PrintPreview
    lr = ThisWorkbook.Worksheets("开单").Cells(Rows.Count, "B").End(xlUp).Row '计算最后一行
    ThisWorkbook.Worksheets("开单").PageSetup.PrintArea = "$A$1:$J$" & lr + 1
    '    Selection.PrintOut Copies:=1, Collate:=True
    ThisWorkbook.Worksheets("开单").PrintPreview
    
    End Sub

    清空数据

    Private Sub CommandButton2_Click() '清空数据
    'Debug.Print 9 + Val(ComboBox1.Value)
    ThisWorkbook.Sheets("开单").Range("E4").Value = "=TODAY()" '文件名
    ThisWorkbook.Sheets("开单").Range("G4").Value = "=E4" '文件名
    
    ThisWorkbook.Sheets("开单").Range("I4").Value = "" '文件名
        For i = 5 To 9
        ThisWorkbook.Sheets("开单").Range("C" & i).Value = "" '文件名
        ThisWorkbook.Sheets("开单").Range("G" & i).Value = "" '项目名称
        Next i
            '--物料信息选择性粘贴--
            lr = ThisWorkbook.Sheets("模板").Cells(Rows.Count, "B").End(xlUp).Row '计算最后一行
            ThisWorkbook.Sheets("模板").Range("B12:i" & lr).Copy ThisWorkbook.Sheets("开单").Range("B12")
    
    MsgBox "数据已清空", vbOKOnly, "提示"
    ThisWorkbook.Worksheets("开单").Activate
    End Sub

    查询工作表

    Private Sub CommandButton9_Click() '查询工作表
    On Error Resume Next
    Application.ScreenUpdating = False
    shname = ThisWorkbook.Worksheets("开单").Range("C6").Value
    If shname = "" Then
    MsgBox "项目名称不能为空", vbOKOnly, "提示": Exit Sub
    End If
    
    '遍历工作簿中的工作表
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name = shname Then
            With ThisWorkbook.Worksheets("开单")
                sh.Range("B4:I4").Copy
                .Range("B4").PasteSpecial Paste:=xlPasteValues '基础数据选择性粘贴
                 sh.Range("B5:C5").Copy
                .Range("B5").PasteSpecial Paste:=xlPasteValues '基础数据选择性粘贴
                '--订单信息选择性粘贴--
                sh.Range("C6:D9").Copy
                .Range("C6").PasteSpecial Paste:=xlPasteValues '订单信息选择性粘贴
                sh.Range("G6:i9").Copy
                .Range("G6").PasteSpecial Paste:=xlPasteValues '订单信息选择性粘贴
                 '--物料信息选择性粘贴--
                 lr = sh.Cells(Rows.Count, "B").End(xlUp).Row '计算最后一行
                 sh.Range("B12:i" & lr).Copy .Range("B12")
                 
                 
            End With
        End If
    Next sh
    Application.CutCopyMode = xlCopy
    MsgBox "项目名称:" & shname & ",查询完毕", vbOKOnly, "提示"
    Application.ScreenUpdating = True
    ThisWorkbook.Worksheets("开单").Activate
    ThisWorkbook.Worksheets("开单").Range("G24").Select
    End Sub

    导入发货单

    Private Sub CommandButton10_Click() '导入发货单
    On Error Resume Next
    Dim Danhao()
    Dim rs As Integer
    
    fname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
    '判断文件是否存在
    If fname <> False Then
        MP = fname
    Else
        MsgBox "没有选中文件"
        Exit Sub
    End If
    MP = fname
    Set wb = Workbooks.Open(MP) '打开文件
    '复制数据
    With ThisWorkbook.Worksheets("开单")
        '车次相关信息复制
         lr = wb.ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row '计算最后一行
         wb.ActiveSheet.Range("B12:B" & lr).Copy
        .Range("D12").PasteSpecial Paste:=xlPasteValues '物料
         wb.ActiveSheet.Range("G12:G" & lr).Copy
        .Range("E12").PasteSpecial Paste:=xlPasteValues '规格
         wb.ActiveSheet.Range("C12:C" & lr).Copy
        .Range("C12").PasteSpecial Paste:=xlPasteValues '规格
        
    '    Dim rngs
    '    rngs = wb.ActiveSheet.Range("C12:C" & lr).Copy
        
    End With
    MsgBox "导入完成", vbOKOnly, "提示"
    
    ThisWorkbook.Worksheets("开单").Activate
    'ThisWorkbook.Worksheets("开单").Range("i4").PasteSpecial Paste:=xlPasteValues '复制数据
     wb.Close False '关闭工作簿
    End Sub

    批量合并

    Private Sub CommandButton11_Click() '批量合并
    On Error Resume Next
    Dim strPath As String
    Dim MyFileDialog As FileDialog
    Dim SelectFiles As Variant
    Application.ScreenUpdating = False
    Set MyFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    '显示打开文件对话框
    Selectfnames = Application.GetOpenFilename("Excel 文件 (*.xl*)," & "*.xl*", , "打开", , True)
    'fname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
    '未选择
    If TypeName(Selectfnames) = "Boolean" Then
    'Debug.Print TypeName(SelectFiles)
    Exit Sub
    End If
    
     '清空数据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 i = 1 To UBound(Selectfnames)
    'Workbooks.Open SelectFiles(i)
    'Debug.Print TypeName(SelectFiles)
    Debug.Print Selectfnames(i)
    Set wb = Workbooks.Open(Selectfnames(i))
     
    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))
    wb.Close False '关闭工作簿
    
    Next i
    
    MsgBox "共计导入" & UBound(Selectfnames) & "堆场", vbOKOnly, "提示"
    ThisWorkbook.Worksheets("送货单").Activate
    Application.ScreenUpdating = True
    '    If MyFileDialog.Show = -1 Then
    '            '使用循环显示选取文件的路径和名称
    '        For Each vrtSelectedItem In MyFileDialog.SelectedItems
    '            strPath = vrtSelectedItem
    '        Next
    '    End If
    '
    'MsgBox strPath
    
    
    
    'Dim fd As FileDialog ', vrtSelectedItem As Variant, iFile As Document
    '    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    '    With fd
    '        .AllowMultiSelect = True
    '        .InitialFileName = ActiveDocument.Path
    '        .Filters.Add "Word文档", "*.doc", 2
    '        .FilterIndex = 2
    '        If .Show <> -1 Then
    '            MsgBox "您没有选择任何文档!", vbCritical
    '            Exit Sub
    '        Else
    '            For Each vrtSelectedItem In .SelectedItems
    '                Set iFile = Documents.Open(vrtSelectedItem)
    '                iFile.Activate
    ''                Call 文档处理
    '                Application.DisplayAlerts = False
    '                iFile.Close True
    '                Application.DisplayAlerts = False
    ''                MsgBox "Selected item's path: " & vrtSelectedItem
    '            Next vrtSelectedItem
    '        End If
    '    End With
    '    Set iFile = Nothing
    '    Set fd = Nothing
    '    MsgBox "ok"
    End Sub

    合并进出库台账:

    Private Sub CommandButton12_Click() '批量合并进出库台账
    On Error Resume Next
    Dim Danhao()
    Dim rs As Integer
    Application.ScreenUpdating = False
    fname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
    '判断文件是否存在
    If fname <> False Then
        MP = fname
    Else
        MsgBox "没有选中文件"
        Exit Sub
    End If
    MP = fname
    Set Wb = Workbooks.Open(MP) '打开文件
    '====批量合并===
    Dim k%
    
     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
     '-----------
    sname = "进出库台账"
    Dtransport = TextBox1.Text '日期确认
    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 ' +
    End If
    
     last_row_clear = ThisWorkbook.Sheets(sname).Cells(Rows.Count, 1).End(xlUp).Row '最后一行位置
     Debug.Print "行数" & last_row_clear
     ThisWorkbook.Sheets(sname).Rows("5:" & last_row_clear).Delete
    '-----------
    ' For i = last_row_clear To 5 Step -1
    'ThisWorkbook.Sheets("进出库").Rows(i).Delete
    'Debug.Print "删除" & i & "行"
    'Next
     '-----------
    stockName = Array("总账(镇江库)", "总账(衢州库)", "总账(诸暨库)", "总账(昆山库)", "总账(泉州库)", "总账(武汉库)", "总账(泗阳库)", "总账(全椒库)")
    
    Wb.Sheets(stockName(0)).Range("a1:Y3").Copy ThisWorkbook.Sheets(sname).Cells(1, 1)  '复制标题
    For i = 0 To UBound(stockName)
    ''Debug.Print i
    '        If i = 0 Then
    '             Wb.Sheets(stockName(0)).Range("a1:Y3").Copy ThisWorkbook.Sheets(sname).Cells(1, 1)  '复制标题
    ''             ThisWorkbook.Sheets(sname).Cells(1, 1).Resize(3, 1) = 1
    '             Else
    '             GoTo 100:
    '        End If
    '100:
        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 Dtransport Then
                            k = k + 1 '记录条目
                            Debug.Print "条目" & k & ":" & Rng.Value & ActiveSheet.Name '输出当前工作表内容
                            
                            last_row = ThisWorkbook.Sheets(sname).Cells(Rows.Count, 1).End(xlUp).Row  '最后一行位置
                            If last_row < 4 Then
                            last_row = 4
                            Else
                            last_row = ThisWorkbook.Sheets(sname).Cells(Rows.Count, 1).End(xlUp).Row  '最后一行位置
                            End If
                            Debug.Print last_row
        '                       n = n + 1 '判断行数
                                ThisWorkbook.Sheets(sname).Cells(last_row, "a").Resize(2, 25) = Rng.EntireRow.Range("a1:y1").Value   '获取对应条目内容
                                ThisWorkbook.Sheets(sname).Cells(last_row, "z").Value = ActiveSheet.Name   '写入表格名称
                        End If
                Next
            End With
    Next
        ThisWorkbook.Sheets(sname).Range("A:L").RowHeight = 15  '行高
    '    ThisWorkbook.Sheets("进出库").Range("C:C").ColumnWidth = 35 '列宽
       Wb.Close False '关闭工作簿
    MsgBox "已汇总完成", vbOKOnly, "提示"
    ThisWorkbook.Worksheets(sname).Activate
    
    
    End Sub

    展开全文
  • 沿用上一篇关于拆分excel工作表的文章的引子,本文分享下多个工作表合并VBA功能。案例仍使用上篇文章的例子。已知有BS、HR等多个部门,分别存放在独立的以部门命名的工作表中,现需要将多个部门的工作表合并为包含...

    沿用上一篇关于拆分excel工作表的文章的引子,本文分享下多个工作表合并的VBA功能。案例仍使用上篇文章的例子。已知有BS、HR等多个部门,分别存放在独立的以部门命名的工作表中,现需要将多个部门的工作表合并为包含所有部门的一张工作表。

    实现代码如下:

    Sub MergeToOneSheet()
    '取表头
    Range("A1:D1") = Sheets(2).Range("A1:D1").Value
    '计算工作表数量
    x = Sheets.Count
    '从第二个工作表循环
    '第一个工作表是新建待合并总表
    For i = 2 To x
    '第i个工作表最后一个非空白行
    rn1 = Sheets(i).Range("A30").End(xlUp).Row
    '待合并完成总表的最后一个非空白行
    rn2 = Range("A30").End(xlUp).Row
    '第i个表第二行到第rn1行拷贝
    Sheets(i).Range("A2:D" & rn1).Copy _
    '粘贴至总表
    Range ("A" & rn2 + 1)
    Next
    End Sub

    有时候需要将工作表单独保存,在手工条件下,一个一个按照制作副本然后另存,是酱紫的:

    表多的时候,一个一个操作再保存会很繁琐,但是VBA可以很轻松的实现此功能。依旧按照之前的文档为例,代码如下:

    Public Sub chaifen()
    Dim sht As Worksheet
    Dim mb As Workbook
    Set mb = ActiveWorkbook
    '循环工作表
    For Each sht In mb.Sheets
    '拷贝工作表
    sht.Copy
    '独立保存位置在桌面"example"文件夹
    ActiveWorkbook.SaveAs Filename:="C:\Users\xj\Desktop\example" _
    & "\" & sht.Name, FileFormat:=xlNormal
    ActiveWorkbook.Close
    Next
    End Sub

    点看桌面“example”文件,所有工作表已经完成独立保存,文件名称也都已经以工作表的名称来命名。

          欢迎大家关注本人微信公众号,公众号将持续更新python,tableau,SQL等数据分析的文章。

       

    ID: DataDreamInitiate

          公众号名称数据分析X小硕
    展开全文
  • 通过MultiSelect:=True参数允许同时选择多个文件,通过定义变量X,将选择的文件名(含路径赋值给X,后指定每个X1在变更集X中,)如何实现通过VBA合并多个指定工作簿到一个新的工作表或者一个工作簿的多个工作表
  • Sub 合并当前工作簿下的所有工作表() Application.ScreenUpdating = False '第一行注释,关闭实时显示执行效果 For j = 1 To Sheets.Count If Sheets(j).Name <> ActiveSheet.Name Then X = Range("A1048576").End...

    本代码源自网络,不知作者是谁。我在分析完代码后,添加了注释,分享给大家,希望对大家有用。直接复制就可以运行了。

    '#######################################################################################################
    '使用说明:
    '本代码适用的Excel文件特征如下;
    '一个Excel文件有多个sheet页,每个sheet页都有一样的标题,需要将多个sheet页合并到一个sheet页
    '当前工作簿新建一个sheet,执行下面代码,将其它sheet合并到此sheet页
    '如果当前执行代码的文件格式为xls格式,第二行注释下面的那一行的代码的A1048576需要改成A65536;
    '#######################################################################################################
    
    Sub 合并当前工作簿下的所有工作表()
    Application.ScreenUpdating = False                  '第一行注释,关闭实时显示执行效果
    For j = 1 To Sheets.Count
       If Sheets(j).Name <> ActiveSheet.Name Then
           X = Range("A1048576").End(xlUp).Row + 1      '第二行注释,当前工作表非空区域最后一行+1,适用于XLSX格式,如果操作为XLS格式文档,需要将A1048576修改为A65536
           Sheets(j).UsedRange.Copy Cells(X, 1)         '第三行注释,将sheet页活动区域复制到当前工作表第X行1列
       End If
    Next
    Range("A1").Select                                  '第四行注释,执行完sheet页复制后,光标落在A1单元格
    Application.ScreenUpdating = True					'第五行注释,关闭实时显示执行效果
    
    MsgBox "当前工作簿下的全部工作表已经合并完毕!", vbInformation, "提示"
    End Sub

     

    展开全文
  • 不熟悉VBA的可以直接下载使用:下载打包的宏文件熟悉VBA的可以拷贝我的代码文件...Sub 表合并() Dim arr(200) As Long #用于统计数 Dim str_arr(200) As String #用于计录文件名 Dim i, n, n_f, r_i, c_i ...

    不熟悉VBA的可以直接下载使用:下载打包的宏文件

    熟悉VBA的可以拷贝我的代码文件自行粘贴或修改以进一步使用:


    '时间:2018/7/13周四
    '作者:Neil
    '
    
    
    Sub 表合并()
        
        Dim arr(200) As Long  #用于统计表数
        Dim str_arr(200) As String #用于计录文件名
        Dim i, n, n_f, r_i, c_i As Long
        
        file_path = ActiveWorkbook.Path + "\excel_files\"
        this_path = ActiveWorkbook.Name
        i = 0
        n = 0
        n_f = 0
        r_i = 0
        c_i = 0
        f = Dir(file_path)
        While f <> ""
            f_h = Left(f, 1)
            If f_h <> "~" Then
                Workbooks.Open (file_path + f)
                Windows(f).Activate
                ActiveWorkbook.Sheets(1).Select
                Range("A1").CurrentRegion.Select
                r_i = Selection.Rows.Count
                c_i = Selection.Columns.Count
                If i = 0 Then
                    Range(Cells(1, 1), Cells(r_i, c_i)).Select
                    Selection.Copy
                Else
                    Range(Cells(2, 1), Cells(r_i, c_i)).Select
                    Selection.Copy
                End If
                n_f = n_f + 1
                Debug.Print i
                Debug.Print r_i
                arr(i) = r_i - 1
                str_arr(i) = f
                Windows(this_path).Activate
                Sheets(Sheets.Count).Activate
                Range(Cells(n + 1, 1), Cells(n + r_i, c_i)).Select
                
                ActiveSheet.Paste
                ActiveSheet.Columns.AutoFit
                Range("A1").Activate
                
                If i = 0 Then
                    n = n + r_i
                Else
                    n = n + r_i - 1
                End If
                i = i + 1
                
            End If
            f = Dir
        Wend
        Windows(this_path).Activate
        Cells(1, 1).Activate
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Select
        Range("A1") = "file_name"
        Range("B1") = "number"
        i = 0
        While i < n_f
            Cells(i + 1, "A") = str_arr(i)
            Cells(i + 1, "B") = arr(i)
            i = i + 1
        Wend
        Cells(n_f + 1, "A") = "共 " + Str(n_f) + " 个文件"
        Cells(n_f + 1, "B") = "共 " + Str(n - 1) + " 行"
        ActiveSheet.Columns.AutoFit
        Range("A1").Activate
    
    End Sub


    展开全文
  • 因同事工作需要,故而开发此程序,同事需求: 1、表格遇到的经常会有不规范的情况,需要获取所有的有数据...Sub 合并所有工作表_在所有行标注工作表名字_无视空行空列_考虑到不规范的多一点的行和列() Dim row_num...
  • 输入以下代码:Private Sub CommandButton1_Click()Dim path, yuan_name '定义路径名,被合并表名称Dim wb As Workbookpath = ThisWorkbook.path '指定路径为合并所在路径yuan_name = Dir(path & "\" & ...
  • 在网上找EXCEL多文件合并的方法,思路: 一、Linux 或者window+cmder,直接用命令行cat合并EXCEL文件,但是,需要安装辅助东西才能直接处理(也许也不可以,但是,可以用文件格式转换工具转换是可行的,把EXCEL文件...
  • 合并多个工作表的数据。在同一个文件夹里,所有的工作簿,每个工作簿的所有工作表合并在一起。最好是格式相同的,合并在一起,效果更加好。VBA实现,办公自动化
  • excel中vba下的代码,合并当前文件夹下所有excel工作表到一个新建的工作表中,并将合并的数据进行横向铺开排列。
  • 批量合并excel工作簿中同名工作表,适用条件: 1、所有要汇总的工作簿在同一个文件夹中,这里以后缀为.xlsx为例; 2、需要合并工作表名称相同(如: “sheet1”),且数据字段一样(如:A列表示序号,B列表示姓名,...
  • VBA - Excel多工作簿合并计算
  • 修改了这片文章中提供的代码https://blog.csdn.net/shuai9201/article/details/73322974以实现合并的结果只有一个表头的功能。 Sub MergeMultiFiles() Dim filePath As String, fileName As String, ...
  • VBA 封装为DLL实例。将当前目录下的工作表清单汇总合并到一张表上,程序简单明了,自己的程序可以直接套用。
  • 这是一个常用而且经典的例子:根据内容,把N个工作表中的内容,合并到一个工作表中; ¤主要知识点¤ 1、工作表选取和内容的复制;...Sub 合并工作表() Dim i As Integer Dim x As Integer, y As Integer Dim
  • 以下的代码功能是:快速合并同一个工作薄中的多个工作表合并成为一个工作表合并之前,请先创建一个空白的 Sheet 作为合并目标 Sheet ,这个 Sheet 必须是第一个 Sheet 。如果不合并标题行(比如第一行)则 j=1 改...
  • VBA工作簿内合并所有工作表

    千次阅读 2018-09-07 13:56:21
    Sub MergeSheets() '工作簿内合并所有工作表 Dim sheetsCount As Long '定义 工作簿内工作表数量 赋值为 sheetCount 数据类型为 Long(长整型) Dim rowCount As Long '定义 汇总表行数 赋值为 rowCount 数据类型为 ...
  • 第三部分为提示,即当合并工作完成后弹出提示。 代码如下: Sub Comb() Dim i% On Error Resume Next Sheets(1).Select Worksheets.Add '新建一个工作表 Sheets(1).Name = "汇总工作表" ...
  • 可以通过该工作簿的代码修改成自己想要的工作簿,方便以后每次汇总多个工作簿
  • 通过VBA合并Excel工作表

    万次阅读 2011-04-16 10:37:00
    工作中经常会用到的把几个Excel文件合并到一个,或者是把一个Excel文件里的所有Sheet合并到一个Sheet来进行统计。下面分别提供用vba宏来解决这两个问题的方法。 1、合并Excel文件 打开一个空Excel...
  • 两个工作表数据合并 vba 在两个工作表合并数据 (Combine Data on Two Worksheets)Have you been experimenting with the Power BI tools that are available in the newer versions of Excel. I've done some work...
  • 為了呈現完整數據或圖表,將所有工作表的數據會整至同一個工作表是常用需求。 %使用條件: 1.各工作表的標籤欄位名稱和數量一致 2.請勿更改該程式檔名 %使用方法: 1.點擊Worksheet combination按鈕。 2.選擇欲...
  • 本代码源自网络,不知作者是谁。我在分析完代码后,添加了注释,并修改了BUG。分享给大家,希望对大家有用。直接复制就可以运行了。 '#############################...'本代码涉及的文件有两类,一类是被合并的Ex...
  • Excel中利用vba将多个sheet合并在一个sheet中的方法

    万次阅读 多人点赞 2019-02-25 23:52:24
    Sub 合并当前工作簿下的所有工作表() Application.ScreenUpdating = False For j = 1 To Sheets.Count If Sheets(j).Name &amp;lt;&amp;gt; ActiveSheet.Name Then X = Range(&quot;A65536&...
  • VBA处理工作表合并单元格 - 格式篇

    千次阅读 2018-03-01 01:49:30
    前言 Excel合并单元格是有人爱有人恨的功能,一般来说数据分析师都非常憎恨这个功能,因为合并单元格常常闹幺蛾子,导致数据统计和格式化障碍重重。...如果数据是有合并单元格的,套用表格格式,杯具了… …,合...
  • 合并工作表.xlsm

    2020-04-28 13:32:47
    合并所有工作表_在所有行标注工作表名字_无视空行空列_考虑到不规范的多一点的行和列
  • 展开全部分太少了,发一个之前写过的合并多张32313133353236313431303231363533e4b893e5b19e31333337393439Excel到单张Sheet的代码,供参考:运行主函数Excels_2_SheetSubdeleteCells()DimsSets=ThisWorkbook.Sheets...
  • 一般的操作方法都是打开两个工作簿,然后选中需要移动的工作表,右键单击以后选择“移动或复制”。接下来在新的窗口里面进行设置就可以了。这种方法适合在移动数量较少的工作表的时候使用。如果有很多的工作簿,都...
  • 开发工具选项卡-Visual Basic,在工程窗口右键插入一个模块,将以下代码复制到代码窗口:Sub 合并单元格()Dim n As Integer, i As IntegerApplication.ScreenUpdating = FalseSet a = Application.InputBox("请选择...

空空如也

空空如也

1 2 3 4 5 ... 20
收藏数 2,933
精华内容 1,173
关键字:

vba合并工作表