多个sheet合并

还是疯子

求助，因为销售分布很多个sheet，想汇总在INDEX的sheet里面，一个一个复制很慢，数据也多，
有没有老师帮忙一下。

1、EXCEL名称都是XX-XX（位数不同，但是都会有-）
2、每张sheet的表头都不要复制到INDEX
3、所有表格的格式都一样的。

shiruiqiang

Sub text()
Dim she As Worksheet
Dim arr, brr(1 To 100000, 1 To 8)
Dim x, y, k
For Each sht In Sheets
If InStr(sht.Name, "INDEX") = 0 Then
arr = sht.UsedRange
For x = 5 To UBound(arr)
    If arr(x, 3) <> "" Then
    k = k + 1
    brr(k, 1) = k
        For y = 3 To UBound(arr, 2)
        brr(k, y - 1) = arr(x, y)
        Next
    End If
Next
End If
Next
Sheets("INDEX").[a2].Resize(k, 5) = brr
End Sub

明天会更好zj

Sub sheetsdata()
Sheets("INDEX").Range("a2:j100000").ClearContents
For Each sht In Sheets
    If sht.Name Like "*-*" Then
        irow = sht.[b65536].End(3).Row - 4
        sht.[b5].Resize(irow, 8).Copy Sheets("INDEX").[a65536].End(3).Offset(1)
    End If
Next
End Sub

liulang0808

...............

gwjkkkkk

Sub TEST()
Dim ar, br, i&, j&, r, wks As Worksheet
    r = 1
    With [a1].CurrentRegion
       .Offset(1).Clear
       ar = .Resize(10 ^ 3)
    End With
    For Each wks In Sheets
       If wks.Name Like "CN*" Then
         With wks
            br = .[B4].CurrentRegion
            For i = 2 To UBound(br)
               r = r + 1
               For j = 1 To UBound(br, 2)
                  ar(r, j) = br(i, j)
               Next j
            Next i
         End With
       End If
    Next
    [a1].Resize(r, UBound(ar, 2)) = ar
    Beep
End Sub

gwjkkkkk

请楼主参考附件 。。。

还是疯子

可以了，谢谢各位。

还是疯子

liulang0808 发表于 2023-1-7 18:20
...............

有个问题，复制的时候如何不复制公式呢？

liulang0808

还是疯子 发表于 2023-1-9 09:30
有个问题，复制的时候如何不复制公式呢？

类似数组赋值可以，
另外拷贝后，选择性粘贴-数值也可以