当前位置: 代码迷 >> VBA >> 如何没人解决这两段稍微长一点的代码呢
  详细解决方案

如何没人解决这两段稍微长一点的代码呢

热度:1086   发布时间:2013-02-26 00:00:00.0
怎么没人解决这两段稍微长一点的代码呢?
继续把没解决代码发上来,希望有人帮忙注释一下。谢谢~~我等阿等啊等。
一、
VB code

  Sub Macro1()
  Dim MyPath$, MyName$, sh As Worksheet, arr, i&, m&, lr&
  Set sh = ActiveSheet
  MyPath = ThisWorkbook.Path & "\"
  MyName = Dir$(MyPath & "*.xls")
  Application.ScreenUpdating = False
  sh.UsedRange.Offset(7).Clear
  Do While MyName <> ""
  If MyName <> ThisWorkbook.Name Then
  m = m + 1
  With GetObject(MyPath & MyName)
  If m = 1 Then
  .Sheets("汇总").UsedRange.Offset(7).Copy sh.[a8]
  lr = .Sheets("汇总").[a65536].End(xlUp).Row - 1
  Else
  arr = .Sheets("汇总").UsedRange
  With sh
  For j = 3 To UBound(arr, 2)
  If .Cells(8, j).HasFormula = False Then
  For i = 8 To lr
  If Len(arr(i, j)) Then .Cells(i, j) = .Cells(i, j) + arr(i, j)
  Next
  End If
  Next
  End With
  End If
  .Close False
  End With
  End If
  MyName = Dir
  Loop
  Application.ScreenUpdating = True
  MsgBox "ok"
End Sub

二、
VB code

Sub chaifen()
Dim arr, brr(), d
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1:k" & Sheet1.[a65536].End(3).Row)
For i = 2 To UBound(arr)
  If Not d.exists(arr(i, 11)) Then
  d(arr(i, 11)) = i
  Else
  d(arr(i, 11)) = d(arr(i, 11)) & "," & i
  End If
Next
k = d.keys
For i = 0 To d.Count - 1
t = Split(d(k(i)), ",")
ReDim brr(1 To UBound(t) + 2, 1 To 11)
m = 1
For n = 1 To 11
  brr(m, n) = arr(1, n)
Next
For j = 0 To UBound(t)
  m = m + 1
  For n = 1 To 11
  brr(m, n) = arr(t(j), n)
  Next
Next
With Sheets.Add(after:=Sheets(Sheets.Count))
  .Columns(1).NumberFormatLocal = "@"
  .Columns(3).NumberFormatLocal = "@"
  .[a1].Resize(m, 11) = brr
  .Name = k(i)
End With
Next
Set d = Nothing
Application.ScreenUpdating = True
Sheet1.Select
End Sub



------解决方案--------------------------------------------------------
真不知道你从哪里找的代码,看的头晕脑胀。第二段不是很清楚,因为看不下去了。

VB code
'做一个表,将指定目录下的所有XLS文件的"汇总表"数据汇总到一个表中Sub Macro1()    Dim MyPath$, MyName$, sh As Worksheet, arr, i&, m&, lr&    Set sh = ActiveSheet    MyPath = ThisWorkbook.Path & "\"    MyName = Dir$(MyPath & "*.xls") '查找XLS文件    Application.ScreenUpdating = False  '禁止屏幕刷新    sh.UsedRange.Offset(7).Clear    Do While MyName <> ""        If MyName <> ThisWorkbook.Name Then '对除本文件以外的XLS进行汇总            m = m + 1   '文件个数            With GetObject(MyPath & MyName)                If m = 1 Then                    '第一个文件直接取数据"汇总"表中的UsedRange.Offset(7)的值到当前工作表的第八行开始的区域                    .Sheets("汇总").UsedRange.Offset(7).Copy sh.[a8]                    lr = .Sheets("汇总").[a65536].End(xlUp).Row - 1 '工作表A列最后一行的行号                Else                    arr = .Sheets(j E
  相关解决方案