批量选择性粘贴并合并工作表的问题

839262551 · 发表于 2014-6-13 21:58

VBA初学者，请教一个关于批量选择性粘贴并且合并数据的问题，谢谢各位帮忙，具体希望达成的结果请见附件，谢谢！

求助.rar (44.07 KB, 下载次数: 8)

839262551 · 发表于 2014-6-14 08:38

chxw68 发表于 2014-6-13 23:27

好用，非常感谢这么晚还为我解答！

839262551 · 发表于 2014-6-14 08:37

zax010 发表于 2014-6-13 23:23
参考附件：

好用，非常感谢这么晚还为我解答！

839262551 · 发表于 2014-6-14 08:37

zax010 发表于 2014-6-13 23:19
Sub zz()
Dim sh As Worksheet
Sheet1.Range("A2:F500") = ""

好用，非常感谢！

chxw68 · 发表于 2014-6-13 23:28

参见附件。

chxw68 · 发表于 2014-6-13 23:27

Sub test()
Dim ws As Worksheet
Dim r%, i%
Dim arr
With Worksheets("汇总")
.UsedRange.Offset(1, 0).Delete
End With
For Each ws In Worksheets
If ws.Name <> "汇总" Then
With ws
.UsedRange = .UsedRange.Value
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a4:f" & r - 1)
For i = 1 To UBound(arr)
arr(i, 6) = ws.Name
Next
With Worksheets("汇总")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(r + 1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
End With
End With
End If
Next
With Worksheets("汇总")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:a" & r)
For i = 1 To UBound(arr)
arr(i, 1) = i
Next
.Range("a2:a" & r) = arr
.Range("a1:f" & r).Borders.LineStyle = xlContinuous
End With
End Sub

复制代码

zax010 · 发表于 2014-6-13 23:23

参考附件：

求助.rar (22.99 KB, 下载次数: 6)

zax010 · 发表于 2014-6-13 23:19

Sub zz()
Dim sh As Worksheet
Sheet1.Range("A2:F500") = ""
For Each sh In Sheets
      If sh.Name <> "汇总" Then
         lr = Sheet1.Range("A1048476").End(xlUp).Row
         sh.Range("B4").Resize(10, 4).Value = sh.Range("B4").Resize(10, 4).Value
         arr = sh.Range("B4").Resize(10, 4)
         With Sheet1
            .Range("B" & lr + 1).Resize(UBound(arr), UBound(arr, 2)) = arr
            .Range("F" & lr + 1).Resize(UBound(arr), 1) = Mid(sh.Name, 1, Len(sh.Name) - 1)
            .Range("A" & lr + 1).Resize(UBound(arr), 1) = "=ROW()-1"
            .UsedRange.Value = .UsedRange.Value
         End With
      End If
Next
End Sub

		自动登录	找回密码
密码			免费注册

[求助] 批量选择性粘贴并合并工作表的问题

评分

评分

评分

最新热点 /1