[已解决]如何将总表分成分表，又将分表合成总表？以A列数据为准。

dyzx

兰色幻想 发表于 2012-4-20 16:59
Sub 拆分表()
Dim wb As Workbook '声明一个工作簿变量
Dim r As Integer, k As Integer '声明r为了存放 ...

兰色幻想老师：如果要将拆分的表格又合并，应该怎样写代码？多谢指教。

itiu201

宝典！学习，拜读

wuyuechina

谢谢，需要好好学习啊

guihuala

我先收藏，然后学习

liyuantaoyy

Sub fenbiao()
Dim a%, b%, c%
Dim arr, arr1
Dim d As New Dictionary
arr = Sheets("总表").Range("A2:F" & Sheets("总表").Range("A65536").End(xlUp).Row)
For a = 1 To UBound(arr)
d(arr(a, 1)) = ""
Next
arr1 = d.Keys
For b = 0 To UBound(arr1)
Worksheets.Add.Name = arr1(b)
Sheets("总表").Range("A1:F1").Copy Sheets(arr1(b)).Range("A1")
Next
For c = 1 To UBound(arr)
For Each sh In Sheets
If arr(c, 1) = sh.Name Then
k = sh.Range("A65536").End(xlUp).Row + 1
sh.Range("A" & k) = arr(c, 1)
sh.Range("B" & k) = arr(c, 2)
sh.Range("C" & k) = arr(c, 3)
sh.Range("D" & k) = arr(c, 4)
sh.Range("E" & k) = arr(c, 5)
sh.Range("F" & k) = arr(c, 6)
End If
Next
Next
End Sub

liyuantaoyy

Sub fenbiao()
Dim a%, b%, c%
Dim arr, arr1
Dim d As New Dictionary
arr = Sheets("总表").Range("A2:F" & Sheets("总表").Range("A65536").End(xlUp).Row)
For a = 1 To UBound(arr)
d(arr(a, 1)) = ""
Next
arr1 = d.Keys
For b = 0 To UBound(arr1)
Worksheets.Add.Name = arr1(b)
Sheets("总表").Range("A1:F1").Copy Sheets(arr1(b)).Range("A1")
Next
For c = 1 To UBound(arr)
For Each sh In Sheets
If arr(c, 1) = sh.Name Then
k = sh.Range("A65536").End(xlUp).Row + 1
sh.Range("A" & k) = arr(c, 1)
sh.Range("B" & k) = arr(c, 2)
sh.Range("C" & k) = arr(c, 3)
sh.Range("D" & k) = arr(c, 4)
sh.Range("E" & k) = arr(c, 5)
sh.Range("F" & k) = arr(c, 6)
End If
Next
Next
End Sub

liyuantaoyy

dyzx 发表于 2015-4-29 09:23
兰色幻想老师：如果要将拆分的表格又合并，应该怎样写代码？多谢指教。

Sub 汇总()
Dim m, n
Sheets("汇总").Range("A1:F200").ClearContents
Sheets("汇总").Range("A1").Resize(1, 6) = Array("班级", "姓名", "准考证号", "行测成绩", "申论成绩", "公共科目总分")
For Each sh In Sheets
If sh.Name <> "汇总" And sh.Name <> "总表" Then
m = Sheets("汇总").Range("A65536").End(xlUp).Row + 1
n = sh.Range("A65536").End(xlUp).Row
arr = sh.Range("A2:F" & n)
Sheets("汇总").Range("A" & m).Resize(n - 1, 6) = arr
End If
Next
End Sub

dyzx

liyuantaoyy 发表于 2015-10-11 21:02
Sub 汇总()
Dim m, n
Sheets("汇总").Range("A1:F200").ClearContents

[size=11.666666030883789px]liyuantaoyy老师：汇总好像有点问题，出现一个对话框。

冬日夏雨

1. Sub 汇总表()
   
2. Application.DisplayAlerts = False
   
3. a = ThisWorkbook.Path
   
4. wjm = Dir(a & "" & "*.xls")
   
5. If wjm <> "总表.xls" Then
   
6. Workbooks.Open (a & "" & wjm)
   
7. Workbooks(wjm).Sheets("sheet1").UsedRange.Copy Workbooks("总表.xls").Sheets("sheet1").Range("a1")
   
8. Workbooks(wjm).Close True
   
9. End If
   
10. Do
    
11. wjm = Dir
    
12. If wjm = "总表.xls" Then
    
13. wjm = Dir
    
14. End If
    
15. If wjm = "" Then
    
16. GoTo tc
    
17. End If
    
18. zh = Workbooks("总表.xls").Sheets("sheet1").UsedRange.Rows.Count
    
19. Workbooks.Open (a & "" & wjm)
    
20. Workbooks(wjm).Sheets("sheet1").UsedRange.Offset(1, 0).Copy Workbooks("总表.xls").Sheets("sheet1").Cells(zh + 1, 1)
    
21. Workbooks(wjm).Close True
    
22. Loop
    
23. tc:
    
24. Workbooks("总表.xls").Sheets("sheet1").UsedRange.SpecialCells(4).Rows.Select
    
25. Selection.Delete shift:=xlUp
    
26. Application.DisplayAlerts = True
    
27. End Sub
    

复制代码

小李子123

最后这个也不行