如何使用偏移量将单个列中的单元格值“重定位”为单个行？

Question

我是一个坏VBA的人。请帮帮我。

我想在一列中重新定位三个值，并使用偏移量将它们放在一行中。我需要将3行数据拼合成单行数据。

这里是代码 - 这是非常粗糙：

Sub Macro1() 
' 
' Macro1 Macro 
' 
    'turn off display update 
    Application.ScreenUpdating = False 

Dim CVFESUMMARY2(2000, 2000) 
Dim MAXROW As Integer 
Dim i As Integer 
Dim r As Range 
Dim x As Range 
Dim y As Range 
Dim z As Range 

Set r = Range("BJ13:BJ512") 
Set x = Range("BK13:BK512") 
Set y = Range("BL13:BL512") 
Set z = Range("BM13:BM512") 

MAXROW = 300 

'format "new" columns 

Range("BK11").Select 
ActiveCell.FormulaR1C1 = "NORM" 

Range("BL11").Select 
ActiveCell.FormulaR1C1 = "MIN" 

Range("BM11").Select 
ActiveCell.FormulaR1C1 = "MAX" 

Columns("BJ:BM").Select 
Selection.ColumnWidth = 12 

'define the "COPY DATA FROM" starting cell location 

Sheets("CVFESUMMARY2").Select 
Range("BJ13").Select 

'cycle through all of the rows in range r 
For i = 1 To MAXROW 

     'copy "BJ13" 
     r.Select 
     Selection.Copy 

     'paste "value only" in column "BK13" 
     x.Select 
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 

     'copy "BJ13+1" 
     Set r = r.Offset(1, 0) 
     r.Select 
     Selection.Copy 

     'paste "value only" in column "BL13" 
     y.Select 
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 

     'copy "BJ13+2" 
     Set r = r.Offset(1, 0) 
     r.Select 
     Selection.Copy 

     'paste "value only" in column "BM13" 
     z.Select 
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 

     'move active cell to "BJ13+4" 
     Set r = r.Offset(2, 0) 

     Set x = x.Offset(4, 0) 
     Set y = y.Offset(4, 0) 
     Set z = z.Offset(4, 0) 
Next i 

'turn on display update 
Application.ScreenUpdating = True 

End Sub 

这个有点工作，但它是在排+2和+3添加值，我不希望;我认为循环是错误的。提前致谢！

以前

后

Answer 1

所需输出，可以将结果进行压缩？ （删除所有空行，留下一块数据），还是在与之链接的列中有信息？

删除多余的行不会太多额外的工作。

使用下面的代码（我认为这是你想要的）MaxRows值是不正确的。它的工作方式应该是MaxRecords即：数据组的数量。

Sub Transpose() 
Dim Position As Range 
Dim Source As Range 
Dim MaxRow As Integer 
Dim Index As Integer 

' set column titles 
Range("BK11").Value2 = "NORM" 
Range("BL11").Value2 = "MIN" 
Range("BM11").Value2 = "MAX" 

' set the width 
Range("BJ:BM").ColumnWidth = 12 

MaxRow = 512 ' see note below 

Set Position = Range("BJ13") ' define the start position 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

'For Index = 1 To MaxRow 
Do 

    ' create a range that contains your first 3 values  
    Set Source = Range(Position, Position.Offset(RowOffset:=2)) 
    ' copy it 
    Source.Copy 
    ' paste and transpose the values into the offset position 
    Position.Offset(ColumnOffset:=1).PasteSpecial xlPasteValues, SkipBlanks:=False, Transpose:=True 
    ' OPTIONAL - Clear the contents of your source range 
    Source.ClearContents 
    ' re-set the position ready for the next iteration 
    Set Position = Position.Offset(RowOffset:=4) 

'Next 
Loop While Position.Row < RowMax 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 

End Sub 

注：我没有用Select和Selection因为他们混淆了我！使用Range()可以更容易地知道你在哪里。

更新我已经包括一个还压缩输出

Sub TransposeCompact() 
Dim Position As Range 
Dim Source As Range 
Dim Destination As Range 
Dim MaxRow As Integer 
Dim Index As Integer 

' set column titles 
Range("BK11").Value2 = "NORM" 
Range("BL11").Value2 = "MIN" 
Range("BM11").Value2 = "MAX" 

' set the width 
Range("BJ:BM").ColumnWidth = 12 

MaxRow = 512 ' see note below 

' define the start position 
Set Position = Range("BJ13") 
' define the first output position 
Set Destination = Position.Offset(ColumnOffset:=1) 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

'For Index = 1 To MaxRow 
Do 

    ' create a range that contains your first 3 values 
    Set Source = Range(Position, Position.Offset(RowOffset:=2)) 
    ' copy it 
    Source.Copy 
    ' paste and transpose the values into the offset position 
    Destination.PasteSpecial xlPasteValues, SkipBlanks:=False, Transpose:=True 
    ' OPTIONAL - Clear the contents of your source range 
    Source.ClearContents 
    ' re-set the position ready for the next iteration 
    Set Position = Position.Offset(RowOffset:=4) 
    ' increment the row on the output for the next iteration 
    Set Destination = Destination.Offset(RowOffset:=1) 

'Next 
Loop While Position.Row < RowMax 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 

End Sub 

更新2 您在使用For Loop变量i没有实际使用，如果你的数据在行13至512那么我对上面的代码所做的编辑应该会有所帮助。

RowMax变量现在将在Position.Row超出它时停止宏。