0

我是一个糟糕的 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 行中添加了我不想要的值；我认为循环是错误的。提前致谢！

前

转换前的数据示例

后

转换后的数据示例

4

1 回答 1

0

你想要的输出，结果可以压缩吗？（删除所有空行，留下一块数据）或者在其链接之前的列中是否有信息？

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

使用以下代码（我认为它可以满足您的需求），该MaxRows值不正确。它的工作方式应该是一个MaxRecordsie：你的数据组数。

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()可以更轻松地了解您在 imo 的位置。

更新我已经包含了一个也可以压缩输出的更新

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

于 2013-03-19T17:07:20.717 回答