VBA для вставки строк между похожими группами, добавления заголовка и вычисления геометрического значения

ProgramBox

VBA для вставки строк между похожими группами, добавления заголовка и вычисления геометрического значения

Post author:admin
Запись опубликована:12 марта, 2023
Post category:Вопросы по программированию

#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      | 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(..)

Я пытался использовать для этого автофильтр, но для этого мне нужно жестко прописать критерии, и, поскольку существует много разных типов групп, должен быть какой-то другой способ, с помощью которого я могу сравнить только первые 9 символов столбца A, а затем вставить пустые строки. Надеюсь, проблема ясна. Заранее спасибо

Ответ №1:

Это должно вывести то, что вы хотите. Не очень элегантно, но должно быть выполнено. Данные должны быть из ячейки 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" amp; 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" amp; t - i   1 amp; ":F" amp; t amp; ")"
    Cells(t   1, 7).Formula = "=GEOMEAN(G" amp; t - i   1 amp; ":G" amp; t amp; ")"
Next m



End Sub

1. Упс, только что понял, что вы сказали первые 9 символов (я только что убрал последние 2). В этом случае измените эту строку DataValue(i) = Left(cell.Value, Len(cell.Value) - 2) на эту DataValue(i) = Left(cell.Value, 9)

2. Я просто решил проблему, создал еще один столбец, содержащий первые 9 символов в качестве значений ячеек, а затем использовал промежуточный итог для их перегруппировки.

3. Просто подумал, что я хотел бы отметить, что, хотя я признаю, что код является беспорядочным и работает только для этого конкретного сценария (т. Е. Он не является универсальным), он, тем не менее, работает. Строка 1 должна быть «Данные — значение 1 — Значение 2», как в приведенном выше сценарии. Если у вас нет строки заголовка в исходных данных, то да, все проблемы, о которых упоминал Тони Даллимор, произойдут, но я сделал это, чтобы решить эту конкретную проблему, точно так, как указано выше. Код грязный, и, вероятно, его можно было бы сделать намного лучше, но он действительно работает!

Ответ №2:

Обычно я не публикую конкурирующий ответ, даже если мне не нравится оригинал. Я сделал здесь исключение по двум причинам:

Я очень недоволен таким подходом.
Это не работает. Строка 1 включена в каждую группу. Первая строка группы не включена в геометрическое значение. Строка заголовка не включается в качестве первой строки каждой группы, как показано в желаемом выводе.

Если вы не уверены, как выполнить подобную задачу, разбейте ее на небольшие шаги. Напишите макрос для шага 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 " amp; PrefixCrnt amp; " from row " amp; RowSrcGrpStart amp; " to " amp; 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 " amp; PrefixCrnt amp; " from row " amp; RowSrcGrpStart amp; " to " amp; 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(" amp; ColNumToCode(ColDestCrnt) amp; RowDestGrpStart amp; ":" amp; _
                          ColNumToCode(ColDestCrnt) amp; RowDestCrnt - 1 amp; ")"
        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) amp; Code
      ColNum = (ColNum - PartNum - 1)  26
    Loop
  End If

  ColNumToCode = Code

End Function