使用 excel VBA Do 循環更改值（將行值更改為列）

Question

親愛的，
我在為下面顯示的圖像循環編寫 VBA 代碼時遇到了問題。

請注意：

1. 行數是動態的
2. 在一次旅行中，車輛將有不止一位顧客
3. 旅行開始到旅行結束的行基礎，但我需要轉移到列基礎（從旅行開始到旅行結束）

請幫忙在循環或數組中編寫 VBA 代碼

謝謝你，阿卜杜勒薩拉姆。

Answer 1

轉置數據

• 將代碼復制到標准模塊中，例如Module1 。
• 仔細調整常量部分中的值。
• 您可以使用同一張工作表，但要適當編輯單元格以免覆蓋數據。

編碼

Option Explicit

Sub getHorizontal()

    ' Constants

    ' Source
    Const srcName As String = "Sheet1"
    Const srcFirst As String = "A1" ' The first cell including the headers.
    ' The following is a keyword that will trigger a new row in the result.
    Const srcTrigger As String = "Trip Start"
    ' Target
    Const tgtName As String = "Sheet2"
    Const tgtFirst As String = "A1"
    ' The number of elements in 'tgtHeaders' will determine the number
    ' of columns in Source Range. If you have more columns, add more headers.
    Dim tgtHeaders As Variant
    tgtHeaders = Array("From", "To")
    ' Define workbook.
    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    ' Declare Success Boolean ('Success').
    Dim Success As Boolean
    
    ' Define Source Data Range and Trigger Count.
    
    ' Define Source Worksheet ('ws').
    Dim ws As Worksheet
    Set ws = wb.Worksheets(srcName)
    ' Define Source First Cell Range ('cel').
    Dim cel As Range
    Set cel = ws.Range(srcFirst)
    ' Define Source Columns Count ('srcColumnsCount').
    Dim srcColumnsCount As Long
    srcColumnsCount = UBound(tgtHeaders) - LBound(tgtHeaders) + 1
    ' Define Find Range ('rng') i.e. the range from First Cell Range
    ' to the bottom cell of the last column.
    Dim rng As Range
    Set rng = ws.Columns(cel.Column).Resize(ws.Rows.Count - cel.Row + 1, _
                                            srcColumnsCount) _
                                    .Offset(cel.Row - 1)
    Set ws = Nothing
    ' Define Source Last Non-Empty Cell Range ('cel').
    Set cel = rng.Find(What:="*", _
                       LookIn:=xlFormulas, _
                       SearchDirection:=xlPrevious)
    ' Validate Source Last Non-Empty Cell Range.
    If cel Is Nothing Then
        GoTo ProcExit ' Find Range is empty (no headers).
    End If
    If cel.Row = rng.Row Then
        GoTo ProcExit ' Find Range consists of only the headers.
    End If
    ' Define Source Data Range ('rng').
    Set rng = rng.Resize(cel.Row - rng.Row).Offset(1)
    Set cel = Nothing
    ' Define Trigger Count ('srcTriggerCount').
    Dim srcTriggerCount As Long
    srcTriggerCount = Application.CountIf(rng.Columns(1), srcTrigger)
    ' Validate Trigger Count.
    If srcTriggerCount = 0 Then
        GoTo ProcExit
    End If
    
    ' Write values from Source Range to Source Array.
    
    ' Write values from Source Range to Source Array ('Source').
    ' Note: The validation of Source Last Non-Empty Cell Range is ensuring
    '       at least two rows in Source Range, so it is a one-liner.
    Dim Source As Variant
    Source = rng.Value
    Set rng = Nothing
    
    ' Write values from Source Array to Target Array.
    
    ' Define initial Target Array.
    Dim Target As Variant
    ReDim Target(1 To srcTriggerCount + 1, 1 To srcColumnsCount)
    'Write initial Headers.
    Dim ArrayOffset As Long
    Dim j As Long
    ArrayOffset = 1 - LBound(tgtHeaders)
    For j = 1 To srcColumnsCount
        Target(1, j) = tgtHeaders(j - ArrayOffset)
    Next j
    ' Define Target Current Number of Columns ('CurrNoC').
    Dim CurrNoC As Long
    CurrNoC = UBound(Target, 2)
    ' Declare additional variables for the upcoming For Next Loop.
    Dim CurrColumn As Long
    Dim CurrentFirst As Variant
    Dim i As Long
    Dim k As Long
    k = 1
    ' Loop through rows of Source Array.
    For i = 1 To UBound(Source)
        ' Write value in first column of current row
        ' to Current First ('CurrentFirst')
        CurrentFirst = Source(i, 1)
        ' Test if Current First is an error value.
        If IsError(CurrentFirst) Then
            ' Note: The possible error value will still be copied. This is just
            '       to avoid an error occurring when comparing Current First
            '       to Source Trigger in the next 'If' statement.
            CurrentFirst = Empty
        End If
        If CurrentFirst = srcTrigger Then
            k = k + 1
            CurrColumn = 0
        Else
            ' When last column of Target Array has been reached.
            If CurrColumn = CurrNoC Then
                ' Increase Current Number of Columns by Source Columns Count.
                CurrNoC = CurrNoC + srcColumnsCount
                ' Resize Target Array.
                ReDim Preserve Target(1 To UBound(Target), 1 To CurrNoC)
                ' Write Headers.
                For j = CurrNoC - srcColumnsCount + 1 To CurrNoC
                    Target(1, j) = Target(1, j - srcColumnsCount)
                Next j
            End If
        End If
        ' Write values from current row in Source Array to Target Array.
        For j = 1 To srcColumnsCount
            CurrColumn = CurrColumn + 1
            Target(k, CurrColumn) = Source(i, j)
        Next j
    Next i

    ' Write values from Target Array to Target Range.
    
    ' Define Target Worksheet ('ws').
    Set ws = wb.Worksheets(tgtName)
    ' Define Target First Cell Range ('cel').
    Set cel = ws.Range(tgtFirst)
    ' Clear contents from Target First Cell Range to the bottom-most cell
    ' of the last column in Target Range.
    cel.Resize(ws.Rows.Count - cel.Row + 1, CurrNoC).ClearContents
    ' Define Target Range ('rng').
    Set rng = cel.Resize(srcTriggerCount + 1, CurrNoC)
    ' Write values from Target Array to Target Range.
    rng.Value = Target
    
    ' Validate Success Boolean.
    
    Success = True

ProcExit:
    
    ' Inform user.
    
    If Success Then
        MsgBox "Data copied.", vbInformation, "Success"
    Else
        MsgBox "Data not copied.", vbCritical, "Fail"
    End If

End Sub