请高手指点一下，感谢

xg_xuhao · 发表于 2018-9-7 16:41

我有一段工作簿合并的代码，现在的需求是要从第2行开始合并，然后有70多列，请高手指点一下，该怎么改

<div class="blockcode"><blockquote>Sub zz()
Dim ar, d As Object, fs(1000), f$, p$, n&, k, t, tt, r&, x(4)
tt = Timer
Set d = CreateObject("scripting.dictionary")
p = ThisWorkbook.Path & ""
f = Dir(p & "*.xlsx")
Application.ScreenUpdating = False
Do While f <> "" And f <> ThisWorkbook.Name
n = n + 1
fs(n) = f
f = Dir
Loop
For ii = 1 To n
Application.StatusBar = "Processing " & ii & " of " & n
f = fs(ii)
With GetObject(p & f).Sheets(1)
r = .[a65536].End(3).Row
ar = .Range("a1:f" & r).Value
Workbooks(f).Close False
For i = 4 To r
If Len(ar(i, 2)) Then
For j = 0 To 4
x(j) = ar(i, j + 1)
Next
k = ar(i, 1)
If Not d.exists(k) Then d(k) = x
End If
Next
End With
Next
k = d.keys
ReDim ar(1 To d.Count, 1 To 60)
For i = 1 To d.Count
t = d(k(i - 1))
For j = 0 To 4
ar(i, j + 1) = t(j)
Next
Next
[a5:f1000].Clear
[a4].Resize(1, 6).Copy
[a4].Resize(d.Count, 6).PasteSpecial xlFormats
[a4].Resize(d.Count, 5) = ar
Set d = Nothing
Application.CutCopyMode = 0
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "used " & Format(Timer - tt, "0.0s")
End Sub

复制代码

xg_xuhao · 发表于 2018-9-7 16:43

有没有高人帮我看看呀，有点急

lanyuu · 发表于 2018-9-7 16:48

vba把多个工作簿合并到一个工作表，然后用excel自带的汇总功能

abc123281 · 发表于 2018-9-7 20:11

想要有答案建议上传附件

xg_xuhao · 发表于 2018-9-7 20:30

abc123281 发表于 2018-9-7 20:11
想要有答案建议上传附件

还有很多列，该怎么弄谢谢坐等

xg_xuhao · 发表于 2018-9-7 20:48

abc123281 发表于 2018-9-7 20:11
想要有答案建议上传附件

怎么样？能指点一下吗？

abc123281 · 发表于 2018-9-7 21:12

Sub 合并工作簿()
Dim wb As Workbook
Dim mypath$, myname$
Dim arr, brr(1 To 1000, 1 To 200)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
mypath = ThisWorkbook.Path & "\"
myname = Dir(mypath & "*.xl*")
Do While myname <> ""
  If myname <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(mypath & myname)
With wb
   With .Worksheets("学生基础信息")
      r = .[a65536].End(xlUp).Row
      c = .Cells(1, .Columns.Count).End(xlToLeft).Column
      arr = .Range("a1").Resize(r, c)
         For i = 2 To UBound(arr)
            If arr(i, 2) <> "" Then
               n = n + 1
               For j = 1 To UBound(arr, 2)
               brr(n, j) = arr(i, j)
               Next
            End If
         Next
      End With
   .Close False
End With
  End If
myname = Dir()
Loop
With Worksheets("学生基础信息汇总")
  .[a2].Resize(n, UBound(brr, 2)) = brr
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "汇总完成!", vbInformation
End Sub

abc123281 · 发表于 2018-9-7 21:12

代码仅供测试参考

汇总abc123.rar (278.18 KB, 下载次数: 5)

xg_xuhao · 发表于 2018-9-7 21:24

abc123281 发表于 2018-9-7 21:12
代码仅供测试参考

谢谢老师，非常感谢

xg_xuhao · 发表于 2018-9-7 21:29

abc123281 发表于 2018-9-7 21:12
代码仅供测试参考

老师，有个问题，本来是58个学生，这一汇总咋多了很多出来了，能优化下吗

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

[求助] 请高手指点一下，感谢

评分