0

私は悪いVBAの人です。私を助けてください。

1つの列に3つの値を再配置し、Offsetを使用してそれらを1つの行に配置したいと思います。3行のデータを1行のデータにフラット化する必要があります。

これがコードです-それは非常に粗雑です:

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