0

1 行のデータを取り、そこから別のワークシートに 2 つの新しい行を作成しようとしています。

元の行には、ルックアップとテーブルから派生したデータに基づく 10 列があります。

次に、特定のセルを特定の順序で配置して、その 1 つの行を 2 つの行にしたいと考えています。

レコーダーを使用してマルコを作成しましたが、それは録音されたものだけを行います。空白のセルが見つかるまで、1行が基づいているシートをループダウンして停止するマルコが必要です。

元のシートの例:

aaa 98765 zx 1a23a xz date amount1 amount2 text 4567 1234

新しいシートは

aaa 98765 zx date amount1 text 1234
aaa 1a23a xz date amount2 text 4567

したがって、元のシートに 2 行ある場合、シート 2 には 4 行というように、元のシートでマクロが空白のセルに遭遇すると、マクロは停止するはずです。

これを行うために私が何をすべきかを誰かが提案できますか?

4

4 に答える 4

1

下記参照。データが A1 で開始し、結果が N1 に出力されることを期待します。これらを変更し、必要に応じてシート参照を追加します。

Option Explicit
Option Base 1

Sub Process()

Dim dataInput() As Variant, dataOutput() As Variant
Dim i As Double

dataInput = Range("A1").CurrentRegion
ReDim dataOutput(UBound(dataInput, 1) * 2, 7)

    For i = 1 To UBound(dataInput) Step 2

        dataOutput(i, 1) = dataInput(1, 1)
        dataOutput(i, 2) = dataInput(1, 2)
        dataOutput(i, 3) = dataInput(1, 3)
        dataOutput(i, 4) = dataInput(1, 6)
        dataOutput(i, 5) = dataInput(1, 7)
        dataOutput(i, 6) = dataInput(1, 9)
        dataOutput(i, 7) = dataInput(1, 10)

        dataOutput(i + 1, 1) = dataInput(1, 1)
        dataOutput(i + 1, 2) = dataInput(1, 4)
        dataOutput(i + 1, 3) = dataInput(1, 5)
        dataOutput(i + 1, 4) = dataInput(1, 6)
        dataOutput(i + 1, 5) = dataInput(1, 8)
        dataOutput(i + 1, 6) = dataInput(1, 9)
        dataOutput(i + 1, 7) = dataInput(1, 11)

    Next i

Range("N1").Resize(UBound(dataOutput, 1), UBound(dataOutput, 2)) = dataOutput

End Sub
于 2012-12-04T12:41:11.243 に答える
0

これがあなたのコードです。私はそれをテストしましたが、うまくいきました。

あなたの質問が明確になったことを願っています。

Sub RECOLOCATE()

Dim i, j As Integer

Dim LastCell As Long

LastCell = ThisWorkbook.Sheets("DataSheet").Range("A100000").End(xlUp).Row - 1

j = 0

For i = 0 To LastCell

    ThisWorkbook.Sheets("NewSheetAdd").Range("A1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("A1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("B1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("B1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("C1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("C1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("D1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("F1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("E1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("G1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("F1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("I1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("G1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("J1").Offset(i, 0).Value

j = j + 1

    ThisWorkbook.Sheets("NewSheetAdd").Range("A1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("A1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("B1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("D1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("C1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("E1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("D1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("F1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("E1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("H1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("F1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("I1").Offset(i, 0).Value
    ThisWorkbook.Sheets("NewSheetAdd").Range("G1").Offset(j, 0).Value _
    = ThisWorkbook.Sheets("DataSheet").Range("K1").Offset(i, 0).Value
j = j + 1

Next i

End Sub

さらにヘルプが必要な場合は、お知らせください。

于 2012-12-04T12:11:59.227 に答える
0

データWorksheet 1がセル A1 から始まるとします。このコードは、データがなくなるまで各行を下に移動し、Worksheet 2.

Sub SplitRowData()
    Dim data as Range, item as range

    Set data = Worksheets(1).Range("A1:A" & Range("A1").End(xlDown).Row)

    For each item in data
        //Add code to work on each row - sample shown below
        With Worksheets(2)
            .Range("A1") = Range("A1")
        End With
    Next item
End Sub

これは役に立ちますか？行を分割するために使用しているコードがわかりません。示されているサンプルは既に畳み込まれているように見え、縮小することができます。

于 2012-12-04T13:07:48.677 に答える
0

あなたが本当にしなければならないことをイメージするのは難しいです。だから私はこの要件に固執します-あなたは1行を取り、そこから2行を作成したいです

次のコードと結果を見てください。

コード：

Option Explicit

Sub blabla()

Dim rngMain As Range
Dim rngFinal As Range
Dim i, j, k, m As Integer
Dim varMain As Variant
Dim varFinal As Variant

Set rngMain = Sheets("Sheet1").Range("A2:B11")
varMain = rngMain.Value

'-- we set second arrays rows into two times of first array, columns remain the same
ReDim varFinal(LBound(varMain) To UBound(varMain) * 2, LBound(varMain, 2) To UBound(varMain, 2))

k = 1
j = 2

For i = LBound(varMain) To UBound(varMain)
 For m = LBound(varMain, 2) To UBound(varMain, 2)
    If k < UBound(varFinal) And j < UBound(varFinal) Then
    '-- here we are just adding the values as it is from input to output
    '-- so you can do any calculation that you need here

        varFinal(k, m) = varMain(i, m)
        varFinal(j, m) = varMain(i, m)
    Else
        Exit For
    End If
  Next m

    k = (i * 2) + 1 '-- 1 * 2 = 2 -> + 1 = 3 --> creating odd
    j = (i * 2) + 2  '-- 2 * 1 = 1 -> + 2 = 4 --> creating even
Next i

'output final array to sheet
Set rngFinal = Sheets("Sheet1").Range("D2")
rngFinal.Resize(UBound(varFinal), UBound(Application.Transpose(varFinal))) = varFinal

End Sub

結果：

ここに画像の説明を入力

二重行の新しいセット内で必要なものについてもう少し明確にできれば、喜んでお手伝いさせていただきます。

于 2012-12-04T13:26:56.967 に答える