повторение значений до следующего столбца

Question

Я пытался решить эту проблему несколькими способами и прочитал много разных сообщений, но я все еще застрял. У меня есть данные, которые есть только в столбце А на Листе 1 в виде списка из нескольких сотен записей, но они неравномерны, поэтому иногда жалоба состоит из нескольких строк или не имеет разрешения (или даже отсутствия жалобы). Однако каждый набор информации начинается со слова "Новая запись". Поэтому я хочу, чтобы на Sheet2, начиная со столбца B, он создавал новый столбец каждый раз, когда встречается новая запись со всеми данными, расположенными ниже, до тех пор, пока не встретится следующая «новая запись». Спасибо миллион раз за помощь.

Данные в настоящее время:

+----+--------------------+
|    |         A          |
+----+--------------------+
|  1 | New Entry          |
|  2 | Smith, Joe         |
|  3 | 15362              |
|  4 | 123-456-7890       |
|  5 | Company1           |
|  6 | Complaint          |
|  7 | Resolution         |
+----+--------------------+
|  8 | New Entry          |
|  9 | Doe, Joe           |
| 10 | 15361              |
| 11 | 234-567-8901       |
| 12 | Company2           |
+----+--------------------+
| 13 | New Entry          |
| 14 | Mary, Joe          |
| 15 | 15360              |
| 16 | 123-097-8641       |
| 17 | Company3           |
| 18 | Complaint          |
| 19 | 2nd line complaint |
| 20 | Resolution         |
+----+--------------------+
| 21 | New Entry          |
| 22 | Doe, Jane          |
| 23 | 15366              |
| 24 | 234-567-8910       |
| 25 | Company4           |
| 26 | Complaint          |
| 27 | Resolution         |
+----+--------------------+

Кому:

+---+--------------+--------------+--------------------+--------------+
|   |      A       |      B       |         C          |      D       |
+---+--------------+--------------+--------------------+--------------+
| 1 | New Entry    | New Entry    | New Entry          | New Entry    |
| 2 | Smith, Joe   | Doe, Joe     | Mary, Joe          | Doe, Jane    |
| 3 | 15362        | 15361        | 15360              | 15366        |
| 4 | 123-456-7890 | 234-567-8901 | 123-097-8641       | 234-567-8910 |
| 5 | Company1     | Company2     | Company3           | Company4     |
| 6 | Complaint    |              | Complaint          | Complaint    |
| 7 | Resolution   |              | 2nd line complaint | Resolution   |
| 8 |              |              | Resolution         |              |
+---+--------------+--------------+--------------------+--------------+

Попытка кода: (Моя попытка была сначала построчной, поэтому я сделал следующий код, который вызывал проблемы, так как данные были неравномерными. Я думал, что столбцы могут быть лучше, если для ввода нового столбца использовалась новая запись.)

Private Sub CommandButton4_Click()
    Dim i As Range
    Dim actualRange As Range
    Dim tmpString As String
    Dim dob As Range
    Dim idn As Range
    Dim comp As Range
    Dim dt As Range
    Dim rsn As Range
    Dim rsn2 As Range
    Dim rsn3 As Range

For Each i In Sheet1.Range("A1:A21303")
    i.Replace "Name ", "Name :"
tmpString = i.Value
    If InStr(i.Value, "Name :") > 0 Then
i.Offset(0, 0).Value = Split(tmpString, ":")(0)
i.Offset(1, 0).Value = Split(tmpString, ":")(1)
Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Offset(1, 0).EntireRow.Value = i.Offset(1, 0).EntireRow.Value
    ElseIf i.Value = "Name" Then
        Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Offset(1, 0).EntireRow.Value = i.Offset(1, 0).EntireRow.Value
    End If
Next i

For Each dob In Sheet1.Range("A1:A21303")
    If dob.Value = "DOB" Then
        Sheet2.Range("B" & Sheet2.Rows.Count).End(xlUp).Offset(1, 0).Value = dob.Offset(1, 0).EntireRow.Value
    End If
Next dob

For Each idn In Sheet1.Range("A1:A21303")
    If idn.Value = "ID Number" Then
        Sheet2.Range("C" & Sheet2.Rows.Count).End(xlUp).Offset(1, 0).Value = idn.Offset(1, 0).EntireRow.Value
    End If
Next idn

For Each comp In Sheet1.Range("A1:A21303")
    If comp.Value = "Company" Then
        Sheet2.Range("D" & Sheet2.Rows.Count).End(xlUp).Offset(1, 0).Value = comp.Offset(1, 0).EntireRow.Value
    End If
Next comp

For Each dt In Sheet1.Range("A1:A21303")
    If dt.Value = "Date/Time" Then
        Sheet2.Range("E" & Sheet2.Rows.Count).End(xlUp).Offset(1, 0).Value = dt.Offset(1, 0).EntireRow.Value
    End If
Next dt

For Each rsn In Sheet1.Range("A1:A21303")
    If rsn.Value = "Complaint" Then
        Sheet2.Range("F" & Sheet2.Rows.Count).End(xlUp).Offset(1, 0).Value = rsn.Offset(1, 0).EntireRow.Value
    End If
Next rsn

For Each rsn2 In Sheet1.Range("A1:A21303")
    If rsn2.Value = "Complaint" Then
        Sheet2.Range("G" & Sheet2.Rows.Count).End(xlUp).Offset(1, 0).Value = rsn2.Offset(2, 0).EntireRow.Value
    End If
Next rsn2

For Each rsn3 In Sheet1.Range("A1:A21303")
    If rsn3.Value = "Complaint" Then
        Sheet2.Range("H" & Sheet2.Rows.Count).End(xlUp).Offset(1, 0).Value = rsn3.Offset(3, 0).EntireRow.Value
    End If
Next rsn3

End Sub

Answer 1

Перспектива - это ключ. То, что вы пытаетесь достичь, это разделить и транспонировать диапазон.

Это решение публикует каждую жалобу по столбцам в новом листе, а также имеет возможность публиковать жалобы в виде списка (по строкам).

Объединяет методы AutoFilter и SpecialCells объекта Range, чтобы установить Range с одним Area на жалобу.

Процедура:

Sub Range_Split_And_Transpose()
Const kItem As String = "New Entry"
Dim iNewEntry As Integer, iRows As Integer
Dim wsSrc As Worksheet, wsTrg As Worksheet
Dim rgData As Range, rgArea As Range
Dim aRcrd As Variant, lRcrds As Long, bItms As Byte

    iNewEntry = MsgBox( _
        "Do you want to include the ""New Entry"" line?", _
        vbApplicationModal + vbQuestion + vbYesNoCancel + vbDefaultButton2, _
        "Range Split & Transpose")
    If iNewEntry = vbCancel Then Exit Sub

    iRows = MsgBox( _
        "Do you want to post the output as a List (by rows)?", _
        vbApplicationModal + vbQuestion + vbYesNoCancel + vbDefaultButton1, _
        "Range Split & Transpose")
    If iRows = vbCancel Then Exit Sub

    Rem Set Objects
    With ThisWorkbook
        Set wsSrc = .Sheets("DATA")
        .Worksheets.Add After:=.Sheets(.Sheets.Count)                           'Adds Output Worksheet
        Set wsTrg = .Worksheets(.Worksheets.Count)
    End With

    Rem Set Range Data
    With wsSrc
        If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter               'Clears AutoFilter
        Set rgData = .Cells(1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)
    End With

    Rem Split Range Into Areas - One Area per Complaint
    With rgData
        .AutoFilter Field:=1, Criteria1:="<>" & kItem
        If .Cells(1).Value2 = kItem Then .Rows(1).EntireRow.Hidden = True
        Set rgData = .SpecialCells(xlCellTypeVisible)
        .Rows(1).EntireRow.Hidden = False
        .Cells(1).AutoFilter
    End With

    Rem Post New Entry Line
    bItms = 1
    If iNewEntry = vbYes Then
        bItms = 2
        With wsTrg.Cells(1, 1)
            If iRows = vbYes Then
                .Resize(rgData.Areas.Count, 1).Value = kItem
            Else
                .Resize(1, rgData.Areas.Count).Value = kItem
    End If: End With: End If

    Rem Post Output
    lRcrds = 0
    For Each rgArea In rgData.Areas

        Rem Record to Array
        aRcrd = WorksheetFunction.Transpose(rgArea.Value2)
        If iRows = vbNo Then aRcrd = rgArea.Value2

        Rem Post Record
        lRcrds = 1 + lRcrds

        If iRows = vbYes Then
            wsTrg.Cells(lRcrds, bItms).Resize(1, rgArea.Rows.Count).Value2 = aRcrd
        Else
            wsTrg.Cells(bItms, lRcrds).Resize(rgArea.Rows.Count, 1).Value2 = aRcrd

    End If:  Next

    wsTrg.UsedRange.Columns.AutoFit

    End Sub

Answer 2

Я бы сделал это так.

Sub Basic_Example_1()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long

    'Fill in the path\folder where the files are
    MyPath = "C:\Users\Ron\test"

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1

    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next

                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C1")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    'if SourceRange use all columns then skip this file
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        'Copy the file name in column A
                        With sourceRange
                            BaseWks.cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(Fnum)
                        End With

                        'Set the destrange
                        Set destrange = BaseWks.Range("B" & rnum)

                        'we copy the values from the sourceRange to the destrange
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next Fnum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

Кроме того, рассмотрите возможность использования надстройки, указанной ниже, особенно если вам нужно делать это часто.

https://www.rondebruin.nl/win/addins/rdbmerge.htm

Answer 3

Попробуйте это:

Sub DoIt()
Dim nur As Long: nur = 1
Dim r As Long
Dim c As Long: c = 1
Dim lROW As Long
With Sheet1
    lROW = .Cells(.Rows.Count, 1).End(xlUp).Row
    For r = 1 To lROW
        If .Cells(r, 1).Value2 = "New entry" Then
            c = c + 1
            nur = 1
        End If
        Sheet2.Cells(nur, c).Value2 = .Cells(r, 1).Value2
        nur = nur + 1
    Next r
End With
End Sub