這是我的代碼：

Sub transposeNumbers()
    Dim c As Range, LastRow As Long, TopN As Long, LastN As Long
    
    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    
    For Each c In ActiveSheet.Range("A2:A" & LastRow)   
        If IsNumeric(c.Offset(-1, 0)) = True Then        
            TopN = c.Row          
        Else        
            If IsNumeric(c.Offset(1, 0)) = True Or c.Row = LastRow Then            
                LastN = c.Row                
                ActiveSheet.Range(ActiveSheet.Cells(TopN, 1), ActiveSheet.Cells(LastN, 1)).Copy
                c.Offset(0, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                Application.CutCopyMode = False            
            End If        
        End If    
    Next c
    
End Sub

我的作業表是這樣的：

我的問題是只考慮最少兩個非數字專案然后它會轉置，或者如果我只有一個非數字專案，它就不會轉置。我不知道如何在該代碼中修復它。

我非常感謝，如果你能幫助我。非常感謝！！

uj5u.com熱心網友回復：

你的問題不清楚，但我認為這就是你想要的，即使這不是最有效的方式。

Sub transposeNumbers()

Dim c As Range, i As Long, rEnd As Range, rStart As Range

Set c = Range("A1")

Do Until IsEmpty(c)
    Do Until IsNumeric(c.Offset(i)) 'find number
        i = i   1
    Loop
    Set rStart = c.Offset(i   1) 'start cell to copy is after the number
    Set c = rStart
    Do Until IsNumeric(c.Offset(i)) 'then continue until find next number
        i = i   1
    Loop
    Set rEnd = c.Offset(i - 1) 'end cell to copy is before the number
    Range(rStart, rEnd).Copy
    rStart.Offset(-1, 1).PasteSpecial Transpose:=True
    Set c = rEnd.Offset(1): i = 0
Loop
    
End Sub

uj5u.com熱心網友回復：

這應該對你有用：

Sub TransposeText()
    Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
    Dim Start As Long, RowCounter As Long, i As Long
    
    With ws
        Dim Data As Range: Set Data = .Range("A1", .Range("A1").End(xlDown))
    
        For i = 1 To Data.Rows.Count   1
            If IsNumeric(Data.Item(i)) Or i = Data.Rows.Count   1 Then
                If Start < RowCounter Then
                    .Range(Data.Item(Start   1), Data.Item(RowCounter)).Copy
                    Data.Item(Start).Offset(0, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                End If
                Start = i
            Else
                RowCounter = i
            End If
        Next i
        Application.CutCopyMode = False
    End With
End Sub

uj5u.com熱心網友回復：

嘗試從第 1 行而不是第 2 行開始回圈。

Sub transposeNumbers()
Dim c As Range, LastRow As Long, TopN As Long, LastN As Long

    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    For Each c In ActiveSheet.Range("A1:A" & LastRow)
        If IsNumeric(c) = True Then
            TopN = c.Row
        Else
            If IsNumeric(c.Offset(1, 0)) = True Or c.Row = LastRow Then
                LastN = c.Row
                ActiveSheet.Range(ActiveSheet.Cells(TopN, 1), ActiveSheet.Cells(LastN, 1)).Copy
                c.Offset(0, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                Application.CutCopyMode = False
            End If
        End If
    Next c

End Sub

前

后

標籤：擅长 vba

上一篇：洗掉包含指定數字范圍之外的值的所有行

下一篇：計算多列的平均值