VBA遍历行以从1个旧行创建2个新行

Question

I am trying to take one row of data and create from it two new rows on another worksheet.

Original row will have 10 columns based on data derived from lookups and tables.

I then want that one row to become 2 rows using certain cells placed in a certain order.

I have created a marco using the recorder, but that only does what is recorded. I need the marco to loop down the sheet where the one row is based until it finds a blank cells and then stop.

Example original sheet will have:

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

New sheet will have

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

So if the original sheet has 2 rows, sheet 2 will have 4 rows and so on, then when the macro encounters ablank cell in the original sheet it should then stop.

Can anyone suggest what I should be doing to do this?

Answer 1

see below. Expecting data to start in A1 and i output results to N1. Change these and add sheet references as relevant:

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

Answer 2

Here is your code, I tested it and it worked just fine.

Hope your question is now clear.

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

If more help is needed just let me know it.

Answer 3

Lets assume your data in Worksheet 1 starts in cell A1. This code will move down each row until no data left and put it in 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

Does this help? I am not sure what code you are using to split the rows. The samples shown already appear to be convoluted and could be scaled back.

Answer 4

It's hard to picture what you really need to do. So I stick to this requirement - you want to take one row and create two rows out of that

Take a look at the following code and the results:

Code:

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

Results:

If you could be a little more clear on what you need within the new set of doubbled-rows, I am happy to help you out.