表格合并时去除表头及表尾

78957031

合并表格时去除标题行
test.rar (45.62 KB, 下载次数: 7)

2019-3-5 19:54 上传

点击文件名下载附件

Sub hztest1()
    Dim sh As Worksheet, brr()
    Set dic = CreateObject("scripting.dictionary")
    x = 1: y = 9
    ReDim brr(1 To 1000, 1 To Sheets.Count + 8)
    For Each sh In Worksheets
        If sh.Name <> ActiveSheet.Name Then
            arr = sh.[b1].CurrentRegion
            y = y + 1
            brr(1, y) = sh.Name & Chr(10) & "????"
            For i = 3 To UBound(arr)
               
                ms = arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6) & arr(i, 7) & arr(i, 8) & arr(i, 9)
                If Not dic.exists(ms) Then
                    x = x + 1
                    dic(ms) = x
                    'brr(x, 1) = arr(i, 1):  brr(x, 2) = arr(i, 2): brr(x, y) = arr(i, 3)
                    brr(x, 2) = arr(i, 2): brr(x, 3) = arr(i, 3): brr(x, 4) = arr(i, 4): brr(x, 5) = arr(i, 5): brr(x, 6) = arr(i, 6): brr(x, 7) = arr(i, 7): brr(x, 8) = arr(i, 8): brr(x, 9) = arr(i, 9): brr(x, y) = arr(i, 11)
                Else
                    brr(dic(ms), y) = brr(dic(ms), y) + arr(i, 11)
                    
                End If
            Next i
        End If
    Next
    With ActiveSheet
        .Cells.ClearContents
        .[a2].Resize(x, y) = brr
        '[a1].Resize(i, 1) = i
        [a2].Resize(1, 9) = Array("???", "???????", "????????", "???????", "?????????", "???", "?????????汾", "?????????????", "??λ")
        Name = "?????"
    End With
End Sub
附件中

78957031

代码在附件中，感谢各位大师

abc123281

Sub hztest1()
Dim sh As Worksheet
Set dic = CreateObject("scripting.dictionary")
Dim brr(1 To 1000, 1 To 10)
For Each sh In Worksheets
  If sh.Name <> "汇总" Then
    aa = sh.Name
    With sh
      r = .[b65536].End(xlUp).Row
      arr = .Range("a1:m" & r)
      For i = 3 To UBound(arr)
        If IsNumeric(arr(i, 1)) Then
          ms = arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6) & arr(i, 7) & arr(i, 8) & arr(i, 9)
          If Not dic.exists(ms) Then
            x = x + 1
            dic(ms) = x
            brr(x, 1) = x
            For j = 2 To 9
              brr(x, j) = arr(i, j)
            Next
            brr(x, 1) = x
            brr(x, 10) = arr(i, 11)
          Else
            brr(dic(ms), 10) = brr(dic(ms), 10) + arr(i, 11)
          End If
        End If
      Next i
    End With
  End If
Next
With Worksheets("汇总")
.Cells.ClearContents
.[a2].Resize(x, 10) = brr
.[a1].Resize(1, 10) = Array("序号", "物料编码", "物料名称", "供应商编号", "供应商名称", "品牌", "供应商物料版本", "供应商物料描述", "单位")
.Range("j1") = aa & "数量"
End With
End Sub

abc123281

test.rar (45.92 KB, 下载次数: 127)

2019-3-5 21:43 上传

点击文件名下载附件

78957031

abc123281 发表于 2019-3-5 21:42
Sub hztest1()
Dim sh As Worksheet
Set dic = CreateObject("scripting.dictionary")

老师，要有多个工作表汇总，怎么实现同样的方式汇总

abc123281

你好  这个就是可以多个工作表汇总  但表格式要一样

abc123281

看下面  代码中循环多工作表的语句

For Each sh In Worksheets