如何使用Offset将单个列中的单元格值“重定位”到单个行？

Question

我是一个糟糕的VBA人。请帮帮我。

我想在一个列中重新定位三个值，并使用Offset将它们放在一行中。我需要将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 实际上并未使用i中使用的For Loop变量，如果您的数据位于第13行至第512行，则我对上述代码所做的编辑应有所帮助。

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