Excel VBA在相似组之间插入行、添加标题和计算几何平均值_Excel_Vba

Excel VBA在相似组之间插入行、添加标题和计算几何平均值

excel vba

Excel VBA在相似组之间插入行、添加标题和计算几何平均值,excel,vba,Excel,Vba,我以以下形式从文本文件导入原始数据： Current table: column1 | column2 | column3 Data | Value1 | Value2 case1_int_a | 1 | 0.76 case1_int_b | 2 | 1.24 case1_fp_x | 3 | 2.00 case1_fp_y | 4 | 3.42 case1_fp_z | 43

我以以下形式从文本文件导入原始数据：

    Current table:
column1     |   column2 | column3
Data        |   Value1  | Value2
case1_int_a |   1       | 0.76
case1_int_b |   2       | 1.24
case1_fp_x  |   3       | 2.00
case1_fp_y  |   4       | 3.42
case1_fp_z  |   43      | 1.876
case2_int_c |   100     | 0.234
case3_int_d |   12      | 1
case3_int_e |   134     | 1.6

Desired Table:
column      |   column2     | column3
Data        |   Value1      | Value2
case1_int_a |   1           | 0.76
case1_int_b |   2           | 1.24
Geomean     |   = GEO(..)   | =GEO(..)

Data        | Value1    | Value2
case1_fp_x  | 3         | 2.00
case1_fp_y  | 4         | 3.42
case1_fp_z  | 43        | 1.876
Geomean     | = GEO(..) | =GEO(..)

Data        | Value1    | Value2
case2_int_c | 100       | 0.234
case3_int_d | 12        | 1
Geomean     | = GEO(..) | =GEO(..)

Data        | Value1    | Value2
case3_int_e | 134       | 1.6
Geomean     | = GEO(..) | =GEO(..)

我尝试使用Autofilter进行此操作，但为此，我需要硬编码标准，并且由于有许多不同类型的组，因此应该有其他方法，仅比较A列的前9个字符，然后插入空行。我希望问题是清楚的。提前感谢

这将输出您想要的内容。不是很优雅，但应该完成工作。数据必须从单元格A1向下。输出到F列到H列

Sub CleanUp()
Dim Row1(3) As String
Dim DataValue() As String
Dim ColumnNum As Integer
Dim DataRange As Range
Dim ValueValues()
Dim Partition() As Integer


ColumnNum = Application.CountA(Range("A:A")) - 1
ReDim DataValue(ColumnNum)
ReDim ValueValues(3, ColumnNum)

Set DataRange = Range("A2:A" & ColumnNum + 1)

Row1(1) = Range("A1").Value
Row1(2) = Range("B1").Value
Row1(3) = Range("C1").Value

i = 0
s = 0

'Populate arrays
ReDim Preserve Partition(1)
Partition(1) = 1

s = 1

For Each cell In DataRange.Cells
    i = i + 1
    DataValue(i) = Left(cell.Value, Len(cell.Value) - 2)
    If i > 1 Then
        If DataValue(i) <> DataValue(i - 1) Then
            s = s + 1
            ReDim Preserve Partition(s + 1)
            Partition(s) = i
        End If
    End If
    ValueValues(1, i) = cell.Value
    ValueValues(2, i) = cell.Offset(0, 1).Value
    ValueValues(3, i) = cell.Offset(0, 2).Value
Next cell

'Output
n = 0
t = -2

Partition(s + 1) = ColumnNum + 1

For m = 2 To s + 1
    t = t + 3
    i = 0
    num = t
    Cells(num, 5).Value = Row1(1)
    Cells(num, 6).Value = Row1(2)
    Cells(num, 7).Value = Row1(3)
    For n = Partition(m - 1) To Partition(m) - 1
        i = i + 1
        Cells(num + i, 5).Value = ValueValues(1, n)
        Cells(num + i, 6).Value = ValueValues(2, n)
        Cells(num + i, 7).Value = ValueValues(3, n)
        t = t + 1
    Next n
    Cells(t + 1, 5).Value = "Geomean"
    Cells(t + 1, 6).Formula = "=GEOMEAN(F" & t - i + 1 & ":F" & t & ")"
    Cells(t + 1, 7).Formula = "=GEOMEAN(G" & t - i + 1 & ":G" & t & ")"
Next m



End Sub

Sub-CleanUp（）
将行1（3）变暗为字符串
Dim DataValue（）作为字符串
Dim ColumnNum作为整数
变暗数据范围作为范围
Dim ValueValues（）
Dim Partition（）作为整数
ColumnNum=Application.CountA（范围（“A:A”））-1
ReDim数据值（ColumnNum）
ReDim ValueValues（3，ColumnNum）
设置DataRange=Range（“A2:A”和ColumnNum+1）
第1行（1）=范围（“A1”）.值
第1行（2）=范围（“B1”）.值
第1行（3）=范围（“C1”）.值
i=0
s=0
'填充数组
ReDim保留分区（1）
分区（1）=1
s=1
对于DataRange.Cells中的每个单元格
i=i+1
数据值（i）=左（cell.Value，Len（cell.Value）-2）
如果i>1，那么
如果数据值（i）数据值（i-1），则
s=s+1
重拨保留分区（s+1）
分区=i
如果结束
如果结束
ValueValues（1，i）=单元格值
ValueValues（2，i）=单元格偏移量（0，1）.Value
ValueValues（3，i）=单元格偏移量（0，2）.Value
下一个细胞
"产出",
n=0
t=-2
分区（s+1）=ColumnNum+1
对于m=2到s+1
t=t+3
i=0
num=t
单元格（num，5）。值=行1（1）
单元格（num，6）。值=行1（2）
单元格（num，7）。值=行1（3）
对于n=分区（m-1）到分区（m）-1
i=i+1
单元格（num+i，5）。Value=ValueValues（1，n）
单元格（num+i，6）。Value=ValueValues（2，n）
单元格（num+i，7）。Value=ValueValues（3，n）
t=t+1
下一个
单元格（t+1,5）。Value=“Geomean”
单元格（t+1,6）。公式=“=GEOMEAN（F”&t-i+1&“：F”&t&”）
单元格（t+1,7）。公式=“=GEOMEAN（G”&t-i+1&“：G”&t&”）
下一个m
端接头

即使我不喜欢原始答案，我通常也不会发布竞争对手的答案。我在这里破例有两个原因：

我对这种做法很不满意
它不起作用。第1行包含在每个组中。组的第一行不包括在Geomean中。标题行不包括在每个组的第一行中，如所需输出中所示

如果您不确定如何完成这样的任务，请将其分解为几个小步骤。为步骤1编写宏。工作时，更新步骤1和2的宏。等等这种方法的优点包括：

一个小步骤更容易编码
通常很容易找到与一小步匹配的现有问题和答案

这里的第一步是确定组。宏

Split1

标识组并将其详细信息输出到即时窗口。对于示例数据，输出为：

Group case1_int from row 2 to 3
Group case1_fp_ from row 4 to 6
Group case2_int from row 7 to 7
Group case3_int from row 8 to 9

请注意，我的第三组和第四组与你的不同

宏

Split2

基于

Split1

构建。它将源标题和每个组复制到目标区域，并添加总计行

Option Explicit
Sub Split1()

  Dim PrefixCrnt As String
  Dim RowSrcCrnt As Long
  Dim RowSrcGrpStart As Long

  With Worksheets("Source")

    RowSrcGrpStart = 2        ' Assumes one header row
    PrefixCrnt = Mid(.Cells(RowSrcGrpStart, 1).Value, 1, 9)
    RowSrcCrnt = RowSrcGrpStart + 1

    Do While True
      If PrefixCrnt <> Mid(.Cells(RowSrcCrnt, 1).Value, 1, 9) Then
        ' Current group finished
        Debug.Print "Group " & PrefixCrnt & " from row " & RowSrcGrpStart & " to " & RowSrcCrnt - 1
        If .Cells(RowSrcCrnt, 1).Value = "" Then
          Exit Do
        End If
        RowSrcGrpStart = RowSrcCrnt
        PrefixCrnt = Mid(.Cells(RowSrcGrpStart, 1).Value, 1, 9)
        RowSrcCrnt = RowSrcGrpStart + 1
      Else
        ' Current group not finished
        RowSrcCrnt = RowSrcCrnt + 1
      End If
    Loop

  End With

End Sub
Sub Split2()

  ' Define number of columns as constant.  I do not think this makes the code
  ' more complicated and it allows for any future addition of a new column
  Const NumCols As Long = 3

  Dim ColDestCrnt As Long
  Dim ColDestStart As Long
  Dim PrefixCrnt As String
  Dim RngHdr As Range
  Dim RngSrc As Range
  Dim RowDestCrnt As Long
  Dim RowDestGrpStart As Long
  Dim RowDestStart As Long
  Dim RowSrcCrnt As Long
  Dim RowSrcGrpStart As Long
  Dim WshtDest As Worksheet

  ' Define the start point for the output which can be the same or a different
  ' worksheet and can be point within the worksheet providing the input and
  ' output ranges do not overlap.  By setting this variables her, it becomes
  ' easy to change them if necessary.  You could have successive days across the
  ' page or under the previous day's output just be changing these variables.

  Set WshtDest = Worksheets("Source")    ' Values for test 2
  ColDestStart = 6
  RowDestStart = 5

  'Set WshtDest = Worksheets("Dest")    ' Values for test 1
  'ColDestStart = 1
  'RowDestStart = 1

  RowDestCrnt = RowDestStart

  With Worksheets("Source")

    ' Assumes one header row
    Set RngHdr = .Range(.Cells(1, 1), .Cells(1, NumCols))
    RowSrcGrpStart = 2

    PrefixCrnt = Mid(.Cells(RowSrcGrpStart, 1).Value, 1, 9)
    RowSrcCrnt = RowSrcGrpStart + 1

    Do While True
      If PrefixCrnt <> Mid(.Cells(RowSrcCrnt, 1).Value, 1, 9) Then
        ' Current group finished
        ' Debug.Print "Group " & PrefixCrnt & " from row " & RowSrcGrpStart & " to " & RowSrcCrnt - 1
        Set RngSrc = .Range(.Cells(RowSrcGrpStart, 1), _
                            .Cells(RowSrcCrnt - 1, NumCols))
        ' Copy header for group
        RngHdr.Copy WshtDest.Cells(RowDestCrnt, ColDestStart)
        RowDestCrnt = RowDestCrnt + 1
        ' Needed for totals row
        RowDestGrpStart = RowDestCrnt
        ' Copy group
        RngSrc.Copy WshtDest.Cells(RowDestCrnt, ColDestStart)
        RowDestCrnt = RowDestCrnt + RowSrcCrnt - RowSrcGrpStart
        ' Build totals row
        WshtDest.Cells(RowDestCrnt, ColDestStart).Value = "Geomean"
        For ColDestCrnt = ColDestStart + 1 To ColDestStart + NumCols - 1
          WshtDest.Cells(RowDestCrnt, ColDestCrnt).Value = _
            "=Geomean(" & ColNumToCode(ColDestCrnt) & RowDestGrpStart & ":" & _
                          ColNumToCode(ColDestCrnt) & RowDestCrnt - 1 & ")"
        Next
        RowDestCrnt = RowDestCrnt + 2
        If .Cells(RowSrcCrnt, 1).Value = "" Then
          Exit Do
        End If
        RowSrcGrpStart = RowSrcCrnt
        PrefixCrnt = Mid(.Cells(RowSrcGrpStart, 1).Value, 1, 9)
        RowSrcCrnt = RowSrcGrpStart + 1
      Else
        ' Current group not finished
        RowSrcCrnt = RowSrcCrnt + 1
      End If
    Loop

  End With

End Sub
Function ColNumToCode(ByVal ColNum As Long) As String

  Dim Code As String
  Dim PartNum As Long

  ' Last updated 3 Feb 12.  Adapted to handle three character codes.
  If ColNum = 0 Then
    ColNumToCode = "0"
  Else
    Code = ""
    Do While ColNum > 0
      PartNum = (ColNum - 1) Mod 26
      Code = Chr(65 + PartNum) & Code
      ColNum = (ColNum - PartNum - 1) \ 26
    Loop
  End If

  ColNumToCode = Code

End Function

选项显式
子拆分1（）
Dim PREFIEXCRNT As字符串
暗淡的行与长的行相同
昏暗的划船开始时一样长
带工作表（“来源”）
RowSrcGrpStart=2'假定为一个标题行
PrefixCrnt=Mid（.Cells（RowSrcGrpStart，1）。值，1，9）
RowSrcRnt=RowSrcGrpStart+1
做正确的事
如果PrefixCrnt Mid（.Cells（RowSrcCrnt，1）.Value，1，9），则
'当前组已完成
调试。打印“组”和“前缀”&“从行”&RowSrcGrpStart&“到”&RowSrcCrnt-1
如果.Cells（RowSrcCrnt，1）.Value=”“则
退出Do
如果结束
RowSrcGrpStart=RowSrcCrnt
PrefixCrnt=Mid（.Cells（RowSrcGrpStart，1）。值，1，9）
RowSrcRnt=RowSrcGrpStart+1
其他的
'当前组未完成
RowSrcCrnt=RowSrcCrnt+1
如果结束
环
以
端接头
子拆分2（）
'将列数定义为常量。我不认为这就是代码
“更复杂，它允许将来添加新的专栏
常量NumCols，长度=3
暗冷如长
最冷的开始时间和最长的一样长
Dim PREFIEXCRNT As字符串
暗RngHdr As范围
Dim RngSrc As范围
昏暗的长椅
朦胧的喧哗和漫长的
开始的时间和开始的时间一样长
暗淡的行与长的行相同
昏暗的划船开始时一样长
将WshtDest设置为工作表
'定义输出的起点，该起点可以是相同的，也可以是不同的
'工作表，可以是工作表中提供输入和
'输出范围不重叠。通过设置该变量，它将成为
“如果需要，很容易更换。你可以在整个世界连续几天
“页面或前一天输出的下方只是更改这些变量。
为测试2设置WshtDest=工作表（“源”）的值
最冷起动=6
RowDestStart=5
为测试1设置WshtDest=工作表（“Dest”）值
'最冷启动=1
'RowDestStart=1
RowDestCrnt=RowDestStart
带工作表（“来源”）
'假定为一个标题行
设置RngHdr=.Range（.Cells（1,1），.Cells（1,NumCols））
RowSrcGrpStart=2
PrefixCrnt=Mid（.Cells（RowSrcGrpStart，1）。值，1，9）
RowSrcRnt=RowSrcGrpStart+1
做正确的事
如果PrefixCrnt Mid（.Cells（RowSrcCrnt，1）.Value，1，9），则
'当前组已完成
'Debug.Print“Group”&PrefixCrnt&“from row”&RowSrcGrpStart&“to”&RowSrcCrnt-1
设置RngSrc=.Range（.Cells（RowSrcGrpStart，1）_
.Cells（RowSrcCrnt-1，NumCols））
'复制组的标题
RngHdr.Copy WshtDest.CELL（RowDestCrnt，最冷启动）
一行