代码之家 › 专栏 › 技术社区 › Todd Choi

Excel VBA将变量列范围转换为变量行

transpose excel vba

Todd Choi · 技术社区 · 7 年前

你好,StackOverFlow社区,

不久前,我开始使用excel vba,对于一个有点复杂的问题,我真的需要一些帮助。

我有一个电子表格,下面有一列“主要”部分及其“替代”部分。我需要创建一个宏,将变量替换部分转移到其相关素数部分的右侧。因此,在下面的例子中,A列中的“P”是素数部分,“A”是交替数:

A. |

1便士 |

1A|

2便士 |

2A|

3A|

我试图创建一个宏,该宏将给出以下结果:

A. || B || C || D |

1便士 |1A | 1A | 1A

1A|

2便士

2A|

3P |3A

3A|

下面是我能够找到的代码,但所有的替代部分都合并到一个范围内,并转换到列表的第一个素数部分。我明白这可能不是我努力实现目标的最佳方法。我对所有的建议持开放态度,并期待听到一些很棒的解决方案。

请注意,上面示例中的粗体素数部分实际上在我的电子表格中突出显示,这将解释代码中的“colorindex=6”

Sub NewHope()

Dim cell As Range
Dim LastRow As Long
Dim Prime As Range
Dim alt As Range


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

For Each cell In Range("A2:A" & LastRow)
    If cell.Interior.ColorIndex = 6 Then
        If Prime Is Nothing Then
            Set Prime = cell
        End If
    Else
        If alt Is Nothing Then
            Set alt = cell
        Else
            Set alt = Union(alt, cell)
        End If

    End If
Next

alt.Copy
Prime.Offset(0, 4).PasteSpecial Transpose:=True

End sub

3 回复 | 直到 7 年前

user8753746 user8753746 7 年前

请尝试以下代码:

Sub test()
Dim cell As Range
Dim LastRow As Long
Dim PrimeRow As Long
Dim PrimeColumn As Long

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

For Each cell In Range("A2:A" & LastRow)
    If cell.Interior.ColorIndex = 6 Then
        PrimeRow = cell.Row
        PrimeColumn = cell.Column + 1
    Else
        Cells(PrimeRow, PrimeColumn).Value = cell.Value
        PrimeColumn = PrimeColumn + 1
    End If
Next

End Sub

user4039065 user4039065 7 年前

If Prime Is Nothing Then

上面的代码似乎不符合您的要求;它不会重置“素数”单元格,因为在“素数”单元格的第一个位置之后,素数将不再为零。

dim r as long, pr as long

For r=2 to Range("A" & Rows.Count).End(xlUp).Row
    If cells(r, "A").Interior.ColorIndex = 6 Then
        pr = r
    Else
        cells(pr, columns.count).end(xltoleft).offset(0,1) = cells(r, "A").value
    End If
Next

如果正确引用父工作表引用,则此代码会更好。

EEM 7 年前

此解决方案使用 AutoFilter , Range.Areas 和 Arrays 为了避免循环通过每个单元,提高处理速度。。。

    Sub TEST_Transpose_Alternates_To_Prime()
    Dim wsTrg As Worksheet, rgTrg As Range
    Dim rgPrime As Range, rgAlter As Range
    Dim rgArea As Range, aAlternates As Variant
    Dim L As Long

        Set wsTrg = ThisWorkbook.Worksheets("DATA")    'Change as required
        With wsTrg
            Application.Goto .Cells(1), 1
            If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
            Set rgTrg = .Cells(6, 2).CurrentRegion.Columns(1)  'Change as required
        End With

        Rem Set Off Application Properties to improve speed
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual

        With rgTrg
            Rem Set Primes Range
            .AutoFilter Field:=1, Criteria1:="=*P"
            Set rgPrime = .Offset(1).Resize(-1 + .Rows.Count).SpecialCells(xlCellTypeVisible)

            Rem Set Alternates Range
            .AutoFilter Field:=1, Criteria1:="=*A"
            Set rgAlter = .Offset(1).Resize(-1 + .Rows.Count).SpecialCells(xlCellTypeVisible)

            Rem Clear Filters
            .AutoFilter
        End With

        Rem Validate Prime & Alternate Ranges
        If rgPrime.Areas.Count <> rgAlter.Areas.Count Then Exit Sub

        Rem Post Alternates besides each Prime
        rgTrg.Cells(1).Offset(0, 1).Value = "Alternates..."

        For Each rgArea In rgAlter.Areas

            With rgPrime

                L = 1 + L
                aAlternates = rgArea.Value2

                If rgArea.Cells.Count > 1 Then
                    aAlternates = WorksheetFunction.Transpose(aAlternates)
                    .Areas(L).Cells(1).Offset(0, 1).Resize(1, UBound(aAlternates)).Value = aAlternates

                Else
                    .Areas(L).Cells(1).Offset(0, 1).Value = aAlternates

        End If: End With: Next

        Rem Refresh Application Properties
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        Application.EnableEvents = True

        End Sub