Excel-vba创建表及粘贴公式结果

Thu, 26 May 2022 22:03:46 +0000

VBA创建新表汇总子sheet结果

源代码

V1.0


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

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

Excel vba修改数据图表格式

Mon, 23 May 2022 22:04:42 +0000

场景描述

修改坐标轴区间及交叉位置

代码

Sub change_pic()
'
' 修改数据图像格式，不需要的可以直接注释或修改参数
'    
    'y轴的显示区间，设置为自动，如果输入自定义，使用.MinimumScale进行赋值
    ActiveChart.Axes(xlValue).MinimumScaleIsAuto = True
    ActiveChart.Axes(xlValue).MaximumScaleIsAuto = True
    'x轴与y轴对齐的y坐标，这里读取了上一步的y轴最小值，即坐标轴放在下方
    ActiveChart.Axes(xlValue).CrossesAt = ActiveChart.Axes(xlValue).MinimumScale
End Sub

VBA on 极客Vinkey

Excel-vba创建表及粘贴公式结果

VBA创建新表汇总子sheet结果

源代码

V1.0

V2.0

Excel vba修改数据图表格式

场景描述

代码