|
|
一直没空直到今天才有空,仔细检查了一遍,发现几处错误,用兰色更正了一下. 其中有个错误是添加空表后,d(ar(1, UBound(ar, 2))) = s就会出现UBound(ar, 2)=0 的 错误,这样肯定会引起错误,很可能就是只观看兄弟指出的错误,谢谢他的提醒,已重新更新请再试.
Private Sub CommandButton1_Click()
Dim arra()
Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
If sh.Name <> "汇总" And sh.Range("a1") <> "" Then
r = sh.Range("iv1").End(xlToLeft).Column
ar = sh.Range("a1").Resize(, r)
For i = 1 To r - 1
If Not d.exists(ar(1, i)) Then
d(ar(1, i)) = s
If i = 1 Then
sql2 = ar(1, i) & ","
Else
sql2 = sql2 & " sum(iif(len(" & ar(1, i) & ")=0,0," & ar(1, i) & ")),"
End If
End If
Next
End If
Next
d(ar(1, UBound(ar, 2))) = s
sql2 = sql2 & " sum( " & ar(1, UBound(ar, 2)) & ") "
arr = d.Keys ': d.RemoveAll
z = 0
With UserForm2.ListView1
For j = 1 To .ListItems.Count
If .ListItems(j).Checked = True Then
z = z + 1
ReDim Preserve arra(1 To z)
With Sheets(.ListItems(j).Text)
r = .Range("iv1").End(xlToLeft).Column
ss = ""
For i = 1 To r
ss = ss & .Cells(1, i) & ","
Next
For i = 0 To UBound(arr)
If InStr(ss, arr(i)) Then
arra(z) = arra(z) & arr(i) & ","
Else
arra(z) = arra(z) & "'' as " & arr(i) & "" & ","
End If
Next
arra(z) = " select " & Left(arra(z), Len(arra(z)) - 1) & " from [" & .Name & "$] "
End With
End If
Next
If z = 0 Then Exit Sub
End With
Sql = Join(arra, " union ") '这里是合并
If UserForm2.OptionButton2.Value = True Then Sql = "select " & sql2 & " from (" & Sql & ") group by " & ar(1, 1) & "" '这里是汇总
'MsgBox Sql
With Sheets("汇总")
.Cells.ClearContents
.Range("a1").Resize(1, UBound(arr) + 1) = d.Keys
.Range("a2").CopyFromRecordset cn.Execute(Sql)
End With
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Call Noclose(Me.Caption)
OptionButton1.Value = True
With Me.ListView1
.ListItems.Clear
.ColumnHeaders.Clear
.View = lvwReport
.FullRowSelect = True
.Gridlines = True
.MultiSelect = True
.CheckBoxes = True
.ColumnHeaders.Add , , "项目", 60
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name <> "汇总" Then .ListItems.Add , , Sheets(i).Name
Next i
'.SelectedItem.Selected = False '不选中
End With
End Sub
附件已更新！
[ 本帖最后由 office2008 于 2009-2-3 11:22 编辑 ] |
|
楼主: wenwen000424
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-2-2 08:24
发表于 2009-2-2 22:59
