Excel, VBA разбивают значение ячейки на несколько строк

Question

Я пытаюсь автоматизировать некоторые фрагменты информации в Excel.

Мне нужно, чтобы значение в столбце A было разделено поровну на количество «Направлений деятельности» (столбец E) и чтобы каждое «Направление деятельности» отображалось в отдельной строке.

Возможно ли это и как это сделать?

---

Вход:

Amount   summary_type   Application         Cost Source   Line of Business
0,6      Employee       eDrive Monitoring   eDrive        R&D; APAC; Group IT;

Ожидаемый результат:

Amount   summary_type   Application         Cost Source   Line of Business
0,2      Employee       eDrive Monitoring   eDrive        R&D;
0,2      Employee       eDrive Monitoring   eDrive        APAC;
0,2      Employee       eDrive Monitoring   eDrive        Group IT;

Answer 1

Если предположить, что все вакансии в разделе «Сфера деятельности» заканчиваются двоеточием, то это возможно с помощью следующего кода:

Помните, что отменить действие нельзя, поэтому сначала сделайте резервную копию.

Public Sub SortRecords()

Dim intENDROW As Integer
Dim intCOUNTER As Integer
Dim intCOUNTER2 As Integer
Dim intSTRINGLENGTH As Integer
Dim intNUMBERCOLON As Integer
Dim intSTARTROW As Integer
Dim currDIVIDED As Currency
Dim intSTART As Integer
Dim intPOS As Integer

intENDROW = Range("A65536").End(xlUp).Row  'Get last row containing data
intSTARTROW = intENDROW + 3

' Re-populate headers
Range("A" & intENDROW + 2).Value = Range("A1").Text
Range("B" & intENDROW + 2).Value = Range("B1").Text
Range("C" & intENDROW + 2).Value = Range("C1").Text
Range("D" & intENDROW + 2).Value = Range("D1").Text
Range("E" & intENDROW + 2).Value = Range("E1").Text

For intCOUNTER = 2 To intENDROW
    intNUMBERCOLON = 0
    intSTART = 1
    intSTRINGLENGTH = Len(Range("E" & intCOUNTER).Text) ' Get length of string containing "Line of Business"
    For intCOUNTER2 = 1 To intSTRINGLENGTH
        If Mid(Range("E" & intCOUNTER).Text, intCOUNTER2, 1) = ";" Then intNUMBERCOLON = intNUMBERCOLON + 1 ' Count how many colons are in this line
    Next

    If intNUMBERCOLON > 0 Then
        currDIVIDED = Range("A" & intCOUNTER).Value / intNUMBERCOLON ' Get average value of Amount column

        For intCOUNTER2 = 1 To intNUMBERCOLON
            intPOS = InStr(intSTART, Range("E" & intCOUNTER).Text, ";", vbTextCompare)  ' Find each instance of a colon
            Range("E" & intSTARTROW + intCOUNTER2 - 1).Value = Mid(Range("E" & intCOUNTER).Text, intSTART, intPOS - intSTART + 1) ' Copy text before colon to new line
            intSTART = intPOS + 2 ' Update start search position
        Next

        For intCOUNTER2 = intSTARTROW To (intNUMBERCOLON + intSTARTROW - 1)
            Range("A" & intCOUNTER2).Value = currDIVIDED
            Range("B" & intCOUNTER2).Value = Range("B" & intCOUNTER).Text
            Range("C" & intCOUNTER2).Value = Range("C" & intCOUNTER).Text
            Range("D" & intCOUNTER2).Value = Range("D" & intCOUNTER).Text

        Next
        intSTARTROW = intSTARTROW + intNUMBERCOLON
    End If
Next

Range("A1", "A65536").NumberFormat = "General" ' Restore Amount column to a standard number

End Sub

И это даст вам из этого:

К этому:

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

Как добавить VBA в MS Office?