Блог

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

Я хочу перенести данные с листа 1 на лист на лист 2.

Лист 1

 a   1   2   3
b   1   2   3   4   5   6
c   1   2   3   4
  

Я пытаюсь написать макрос, который перенесет данные на лист 2 следующим образом:

 a   1
a   2
a   3
b   1
b   2
b   3
b   4
b   5
b   6
c   1
c   2
c   3
c   4
  

Я пытался написать некоторый код на VBA, но я понятия не имею, как подойти к этой конкретной проблеме. Я пытался использовать циклы Do Until, но проблема, с которой я столкнулся, заключается в том, как я получаю буквы на листе 1, столбец 1 для вставки с соответствующими номерами на листе 2.

Друг сделал для меня некоторый код для анализа, но это смутило меня еще больше. Это работает для этого набора данных, но не удается сделать это с большим набором данных (тем, где буквы доходят до ‘z’).

Вот его код:

 Sub transpose()
    Sheets(1).Select

    lrow1 = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 1 To lrow1
        nums = 2

        Cells(i, nums).Select

        Do Until IsEmpty(ActiveCell)
            nums = nums   1
            Cells(i, nums).Select
        Loop

        Range(Cells(i, 2), Cells(i, nums)).Copy
        Sheets(2).Select

        lrow2 = Cells(Rows.Count, 2).End(xlUp).Row

        Cells(lrow2   1, 2).Select

        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, transpose:=True

        Sheets(1).Select

        Cells(i, 1).Copy

        Sheets(2).Select

        Cells(lrow2   1, 1).Select

        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, transpose:=False

        lrow3 = Cells(Rows.Count, 2).End(xlUp).Row

        Cells(lrow2   1, 1).Select

        Selection.AutoFill Destination:=Range(Cells(lrow2   1, 1), Cells(lrow3, 1)), Type:=xlFillDefault

        Sheets(1).Select
    Next i

    Sheets(2).Select

    Rows("1:1").Select

    Selection.Delete Shift:=xlUp
End Sub
  

https://pastebin.com/J45fmYKj

Это сделает это за вас…

 Public Sub TransformData()
    Dim lngRow As Long, lngEndRow As Long, objSrcSheet As Worksheet, objDestSheet As Worksheet
    Dim strLetter As String, strNumber As String, lngCol As Long, lngWriteRow As Long

    Set objSrcSheet = Sheet1
    Set objDestSheet = Sheet2

    lngEndRow = objSrcSheet.Range("A" amp; objSrcSheet.Rows.Count).End(xlUp).Row

    With objSrcSheet
        For lngRow = 1 To lngEndRow
            strLetter = .Cells(lngRow, 1)

            If strLetter <> "" Then
                For lngCol = 2 To .Columns.Count
                    strNumber = .Cells(lngRow, lngCol)

                    If strNumber = "" Then Exit For

                    lngWriteRow = lngWriteRow   1

                    objDestSheet.Cells(lngWriteRow, 1) = strLetter
                    objDestSheet.Cells(lngWriteRow, 2) = strNumber
                Next
            End If
        Next
    End With
End Sub
  

… Я решил предоставить вам полное решение. Правильно или неправильно, лучше или хуже, вот как я бы это сделал, и, учитывая, что вы учитесь, я надеюсь, это поможет вам. Также используется подход, при котором SELECT не используется, что не приведет ни к чему большему, чем замедление работы, и считается крайне плохой практикой.

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

Простой метод, связанный с Excel, заключается в использовании Power Query aka Getamp;Transform . Выберите первый столбец, а затем unpivot Other столбцы. Все это можно сделать из пользовательского интерфейса.

Если вы хотите иметь макрос, который использует циклы для достижения того же конечного результата, я бы сделал, как показано ниже. Обратите внимание, что я выполняю цикл в массивах VBA, а не использую повторяющиеся вызовы к / из листа. Это гораздо более быстрый метод.

 Option Explicit
Sub due()
    'Declare the variables
    Dim WS1 As Worksheet, WS2 As Worksheet
    Dim rSrc As Range, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim lRC() As Long
    Dim I As Long, J As Long, K As Long

'Set Worksheet and Range variables
'Determine Last Row and Column of the range, assuming starts in A1
Set WS1 = Sheet1
Set WS2 = Sheet2
    Set rRes = WS2.Cells(1, 1)
lRC = LastRowCol(WS1.Name)

'Read the source data into a VBA array
'much faster than operating on the worksheet
With WS1
    Set rSrc = .Range(.Cells(1, 1), .Cells(lRC(0), lRC(1)))
    vSrc = rSrc
End With

'size the results array
'note that `Count` will only count the numeric entries, which is what we want
'might have to use a different computation if there is not a nice text/number
'differentiation between column 1 and the rest of the data
ReDim vRes(1 To WorksheetFunction.Count(rSrc), 1 To 2)

'Here is the loop
'we go through the source data one row at a time
'writing to the results array as you can see
'Need to check for blank entries since not all rows are the
' same length.
K = 0
For I = 1 To UBound(vSrc, 1)
    For J = 2 To UBound(vSrc, 2)
        If vSrc(I, J) <> "" Then
            K = K   1
            vRes(K, 1) = vSrc(I, 1)
            vRes(K, 2) = vSrc(I, J)
        End If
    Next J
Next I

'write the results to the destination worksheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
End With

End Sub

Function LastRowCol(Worksht As String) As Long()
Application.Volatile
    Dim WS As Worksheet, R As Range
    Dim LastRow As Long, LastCol As Long
    Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
    Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlFormulas, lookat:=xlPart, searchorder:=xlByRows, _
                    searchdirection:=xlPrevious)

    If Not R Is Nothing Then
        LastRow = R.Row
        LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlFormulas, lookat:=xlPart, searchorder:=xlByColumns, _
                    searchdirection:=xlPrevious).Column
    Else
        LastRow = 1
        LastCol = 1
    End If
End With

L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function
  

Исходные данные

Результаты

Может быть проще ориентироваться (и, безусловно, быстрее) в работе с массивами.

 Option Explicit

Sub stackTranspose()

    Dim i As Long, j As Long, k As Long, vals As Variant, arr As Variant

    'collect original values into source array
    With Worksheets(1)
        vals = .Cells(1, "A").CurrentRegion.Value2
    End With

    'redimension target array and set k for first 'row'
    ReDim arr(1 To Application.Count(vals), 1 To 2)
    k = 1

    'loop through source and transfer transposed values
    For i = LBound(vals, 1) To UBound(vals, 1)
        For j = LBound(vals, 2)   1 To UBound(vals, 2)
            'is there a value to transfer?
            If vals(i, j) <> vbNullString Then
                arr(k, 1) = vals(i, LBound(vals, 2))
                arr(k, 2) = vals(i, j)
                'increment target 'row'
                k = k   1
            Else
                'blank value; move to next source 'row'
                Exit For
            End If
        Next j
    Next i

    'put target values into Sheeet2
    With Worksheets(2)
        .Cells(1, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With

End Sub