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

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

  •  2
  • Todd Choi  · 技术社区  · 7 年前

    你好,StackOverFlow社区,

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

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

    A. |

    1便士 |

    1A|

    1A|

    1A|

    2便士 |

    2A|

    2A|

    3P

    3A|

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

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

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

    1A|

    1A|

    1A|

    2便士

    2A|

    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 年前
        1
  •  2
  •   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
    
        2
  •  0
  •   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
    

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

        3
  •  0
  •   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