Excel VBA将variables列范围转置为variables行

你好，StackOverFlow社区，

我不久前就开始使用excel vba，可以真正使用一些有点复杂的问题。

我有一个电子表格，其中包含一列“主要”部分和其下方的“备选”部分。 我需要创build一个macros，将可变替代部分转置到其关联Prime部分的右侧。 因此，对于下面的例子，在列A中，“P”是主要部分，“A”是阿尔泰特：

A |

1P |

1A |

1A |

1A |

2P |

2A |

2A |

3P |

3A |

我试图创build一个macros将给我以下结果：

A || B || C || D |

1P | 1A | 1A | 1A

1A |

1A |

1A |

2P | 2A | 2A

2A |

2A |

3P | 3A

3A |

下面是我能够想到的代码，但所有替代部分合并成一个范围，并转换到列表的第一个总理部分。 我明白，这可能不是我想要完成的最好的方法。 我愿意接受所有的build议，期待听到一些很棒的解决scheme。

请注意，上例中的Bolded Prime部分实际上在我的电子表格中突出显示，这将解释代码中的“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 

Answer 1

试试这个代码：

 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 

Answer 2

 If Prime Is Nothing Then 

上面的代码似乎没有做你所需要的; 它不会重置“主要”单元格，因为在“主要”单元格的第一个位置之后，Prime将永远不会再有任何东西。

 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 

这个代码会更好地适当引用父工作表引用。

Answer 3

此解决scheme使用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