如何让excel根据条件自动填写数据到相应工作表

funfox

jzds123 发表于 2015-1-16 15:18
感谢feiren228 老师和chxw68 老师的帮忙，非常好用，谢谢！

feiren228 老师和chxw68 老师，两位老师都好厉害啊！！！

小弟也想学习学习！

可否请楼主帮忙测试一下～

感激！

• Dim rngAdr As Range, 地址, 人数
• Sub takeaway()
• Application.ScreenUpdating = False
• 算人数
• 复制and贴上
• Worksheets("成绩总表").Columns("I:K").Clear
• With Application
•    .CutCopyMode = False
•     .ScreenUpdating= True
• End With
• End Sub
• Private Sub 复制and贴上()
• Application.ScreenUpdating = False
• Dim rngCopd As Range, rngCopda As Range, rngSbt AsRange
• Dim i人, i位, i表rAs Integer, i表cAs Integer
• Dim cc As String
• With rngAdr
•     i人 = 0: i表r = 0: t = 0
•     For Eachi位 In 地址
•     i人 = i人 + 1
•         Set rngCopd = .Parent.Range("C"& i位,"G" & i位 +人数(i人, 1) - 1)
•         cc =.Item(i人).Value
•         SetrngSbt = Worksheets(Left(cc, 3)).Cells.Find(What:=cc, MatchCase:=True)
•     With rngSbt
•         For i表c = 0 To 3
•            With rngCopd
•                Set rngCopda = Intersect(.Offset, .Parent.Range(.Item(1), .Item(28, 5)).Offset(i表c * 28))
•            End With
•            If rngCopda Is Nothing Then
•            Else
•                rngCopda.Copy
•                rngSbt.Item(3, i表c* 7).PasteSpecial xlPasteValues
•            End If
•         Next
•            With rngAdr
•                On Error Resume Next
•                i表r= IIf(Left(.Item(i人).Value,3) = Left(.Item(i人 +1).Value, 3), i表r+ 1, 0)
•            End With
•     End With
•     Next
• End With
• With Application
•     .CutCopyMode= False
•    .ScreenUpdating = True
• End With
• End Sub
• Private Sub 算人数()
• Application.ScreenUpdating = False
• Dim iAdr As Long
• With Worksheets("成绩总表")
•    .Range(.Cells(10), .Cells(11)).Value = Array("地址", "人数")
•     SetrngAdr = .Cells(65536, 1).End(xlUp)
•    .Columns("A:A").Copy
•     With.Columns("I:I")
•         .PasteSpecialPaste:=xlPasteValues
•        .RemoveDuplicates 1, 1
•         WithRange(.Cells(2), .Cells(65536).End(xlUp))
•            .Offset(, 1).FormulaArray = "=MATCH(" & .Address &",A:A,0)"
•             .Offset(,2).FormulaR1C1 = "=R[1]C[-1]-RC[-1]"
•            With Union(.Offset(, 1), .Offset(, 2))
•                .Copy
•                .PasteSpecial xlPasteValues
•                .Cells(.Count).Value = rngAdr(1, 2).Value
•            End With
•            Set rngAdr = .Offset
•             地址 = .Offset(, 1).Value
•             人数 = .Offset(, 2).Value
•         EndWith
•     End With
• End With
• With Application
•    .CutCopyMode = False
•    .ScreenUpdating = True
• End With
• End Sub
  

zwscxx2003

看着真眼热啊，虽然看不懂。以后要学习提高的地方真是太多了。

jzds123

funfox 发表于 2015-1-17 11:01
feiren228 老师和chxw68 老师，两位老师都好厉害啊！！！小弟也想学习学习！可否请楼主帮忙测试一下～感激 ...

谢谢funfox老师的关注和帮忙，这几天忙着学校的考试工作，没时间上来看，所以直到今天才看到你的回复，不好意思！
把你的代码写入到vba里进行了一下测试，在运行时提示“语法错误”，不知为何？截图如下：
因为马上面临考试和期末工作，很多事情都还得去考虑和布置，没多少时间再进行测试，请老师下载我的附件，再做测试吧，谢谢！

funfox

1. 
   
2. 
   
3. Dim rngAdr As Range, 地址, 人数
   
4. Sub takeaway()
   
5. Application.ScreenUpdating = False
   
6. 算人数
   
7. 复制and贴上
   
8. Worksheets("成绩总表").Columns("I:K").Clear
   
9. With Application
   
10.     .CutCopyMode = False
    
11.     .ScreenUpdating = True
    
12. End With
    
13. End Sub
    
14. Private Sub 复制and贴上()
    
15. Application.ScreenUpdating = False
    
16. Dim rngCopd As Range, rngCopda As Range, rngSbt As Range
    
17. Dim i人, i位, i表r As Integer, i表c As Integer
    
18. Dim cc As String
    
19. With rngAdr
    
20.     i人 = 0: i表r = 0: t = 0
    
21.     For Each i位 In 地址
    
22.     i人 = i人 + 1
    
23.         Set rngCopd = .Parent.Range("C" & i位, "G" & i位 + 人数(i人, 1) - 1)
    
24.         cc = .Item(i人).Value
    
25.         Set rngSbt = Worksheets(Left(cc, 3)).Cells.Find(What:=cc, MatchCase:=True)
    
26.     With rngSbt
    
27.         For i表c = 0 To 3
    
28.             With rngCopd
    
29.                 Set rngCopda = Intersect(.Offset, .Parent.Range(.Item(1), .Item(28, 5)).Offset(i表c * 28))
    
30.             End With
    
31.             If rngCopda Is Nothing Then
    
32.             Else
    
33.                 rngCopda.Copy
    
34.                 rngSbt.Item(3, i表c * 7).PasteSpecial xlPasteValues
    
35.             End If
    
36.         Next
    
37.            With rngAdr
    
38.                 On Error Resume Next
    
39.                i表r = IIf(Left(.Item(i人).Value, 3) = Left(.Item(i人 + 1).Value, 3), i表r + 1, 0)
    
40.             End With
    
41.    End With
    
42.     Next
    
43. End With
    
44. With Application
    
45.     .CutCopyMode = False
    
46.     .ScreenUpdating = True
    
47. End With
    
48. End Sub
    
49. Private Sub 算人数()
    
50. Application.ScreenUpdating = False
    
51. Dim iAdr As Long
    
52. With Worksheets("成绩总表")
    
53.     .Range(.Cells(10), .Cells(11)).Value = Array("地址", "人数")
    
54.     Set rngAdr = .Cells(65536, 1).End(xlUp)
    
55.     .Columns("A:A").Copy
    
56.     With .Columns("I:I")
    
57.         .PasteSpecial Paste:=xlPasteValues
    
58.         .RemoveDuplicates 1, 1
    
59.         With Range(.Cells(2), .Cells(65536).End(xlUp))
    
60.             .Offset(, 1).FormulaArray = "=MATCH(" & .Address & ",A:A,0)"
    
61.             .Offset(, 2).FormulaR1C1 = "=R[1]C[-1]-RC[-1]"
    
62.             With Union(.Offset(, 1), .Offset(, 2))
    
63.                 .Copy
    
64.                 .PasteSpecial xlPasteValues
    
65.                 .Cells(.Count).Value = rngAdr(1, 2).Value
    
66.             End With
    
67.             Set rngAdr = .Offset
    
68.             地址 = .Offset(, 1).Value
    
69.             人数 = .Offset(, 2).Value
    
70.         End With
    
71.     End With
    
72. End With
    
73. With Application
    
74.     .CutCopyMode = False
    
75.     .ScreenUpdating = True
    
76. End With
    
77. End Sub
    
78. '空格键消失了，真是罪过！
    

复制代码

超越者

点赞学习，感谢了！

LMY123

总表数据填入分表