VBA创建新表汇总子sheet结果

源代码

V1.0

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

Public Sub abs_and_average()
    On Error Resume Next  '这样不会报错。下标越界
    If IsEmpty(Worksheets("data")) Then
            Sheets.Add after:=Sheets(Sheets.Count)
          Sheets(Sheets.Count).Name = "data"
      Else
           Worksheets("data").UsedRange.ClearContents
      End If
  
  
  insertline=0
  For Each usedsheet In Worksheets:
  insertline=insertline+1
      If usedsheet.Range("b12") = "Cd3" Then
          usedsheet.Range("w14").FormulaR1C1 = "齿轮箱输入转速(r/min)的绝对值"
          usedsheet.Range("p10").FormulaR1C1 = "输入轴转速"
      
          '单元格输入公式，相对引用（可以通过录制宏进行修改替换）
          usedsheet.Range("w15").FormulaR1C1 = "=abs(RC[-1])"
          
      
          '判断需要填充多长，这里从第30行开始向后循环判断非空单元格
          i = 30
          While usedsheet.Cells(i + 1, 10) <> ""
              i = i + 1
          Wend
          cc = "w15:v" & i
      
          '使用range的方法，向下填充，还有其他功能，可以通过录制宏查看
          usedsheet.Range(cc).FillDown
          usedsheet.Range("q10").Formula = "=AVERAGE(U3964:U5014)"


        '把平均值输出到汇总表
        Worksheets("data").cells(insertline,1)=split(usedsheet.name,"=")(0)
        Worksheets("data").cells(insertline,2)=split(usedsheet.name,"=")(1)
        Worksheets("data").cells(insertline,3)=usedsheet.Range("Q10").value

      Else
  
      End If
  Next
  ' 显示适当列宽
 Worksheets("data").range("A:c").EntireColumn.AutoFit
 Worksheets("data").Sort.SortFields.Clear
 Worksheets("data").Sort.SortFields.Add2 Key:=Range("B1:B20"), _
      SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  With Worksheets("data").Sort
      .SetRange Range("A1:C20")
      .Header = xlGuess
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
  End With
  End Sub

V2.0

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Public Sub abs_and_average0528()
    On Error Resume Next  '这样不会报错。下标越界
    If IsEmpty(Worksheets("data")) Then
            Sheets.Add after:=Sheets(Sheets.Count)
          Sheets(Sheets.Count).Name = "data"
      Else
           Worksheets("data").UsedRange.ClearContents
      End If
  
  
  insertline=0
  For Each usedsheet In Worksheets:
  insertline=insertline+1
      If usedsheet.Range("b10") = "Cd3" Then
        '判断需要目标行数，这里从第30行开始向后循环判断非空单元格
        i = 30
        While Cells(i+1, 10) <> ""
            i = i + 1
        Wend
        cc = "u12:x" & i
        usedsheet.range(cc).clear
        '单元格输入文字
        usedsheet.Range("U12").FormulaR1C1 = "发电机转速（r/min）"
        usedsheet.Range("v12").FormulaR1C1 = "齿轮箱输入转速(r/min)"
        usedsheet.Range("w12").FormulaR1C1 = "【绝对值】发电机转速（r/min）"
        usedsheet.Range("x12").FormulaR1C1 = "【绝对值】齿轮箱输入转速(r/min)"


        '单元格输入公式，相对引用
        usedsheet.Range("U13").FormulaR1C1 = "=RC[-1]*60/2/3.1415926"
        usedsheet.Range("V13").FormulaR1C1 = "=RC[-19]*60/2/3.1415926"
        '单元格输入公式，直接输入内容
        usedsheet.Range("w13").Formula = "=abs(u13)"
        usedsheet.Range("x13").Formula = "=abs(v13)"

          
      
          '判断需要填充多长，这里从第30行开始向后循环判断非空单元格
          i = 30
          While usedsheet.Cells(i + 1, 10) <> ""
              i = i + 1
          Wend
          cc = "u13:x" & i
      
          '使用range的方法，向下填充，还有其他功能，可以通过录制宏查看
          usedsheet.Range(cc).FillDown


          usedsheet.Range("w11").Formula = "=AVERAGE(w1412:w50012)"
          usedsheet.Range("x11").Formula = "=AVERAGE(x1412:x50012)"


        '把平均值输出到汇总表
        Worksheets("data").cells(1,1)= "sheet name"
        Worksheets("data").cells(1,2)="【绝对值】发电机转速（r/min）"
        Worksheets("data").cells(1,3)="【绝对值】齿轮箱输入转速(r/min)"
        Worksheets("data").cells(insertline+1,1)=usedsheet.name
        Worksheets("data").cells(insertline+1,2)=usedsheet.Range("w11").value
        Worksheets("data").cells(insertline+1,3)=usedsheet.Range("x11").value

      Else
  
      End If
  Next
' 显示适当列宽
  Worksheets("data").range("A:c").EntireColumn.AutoFit
'  Worksheets("data").Sort.SortFields.Clear
'  Worksheets("data").Sort.SortFields.Add2 Key:=Range("B1:B20"), _
'       SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'   With Worksheets("data").Sort
'       .SetRange Range("A1:C20")
'       .Header = xlGuess
'       .MatchCase = False
'       .Orientation = xlTopToBottom
'       .SortMethod = xlPinYin
'       .Apply
'   End With
  End Sub

许可协议

本文采用 署名-非商业性使用-相同方式共享 4.0 国际 许可协议，转载请注明出处。