Question

我正在尝试获取一行数据并在另一个工作表上创建两个新行。

根据从查找和表格派生的数据，原始行将有10列。

然后我希望使用按特定顺序放置的某些单元格将一行变为2行。

我使用录音机创建了一个marco，但这只会记录下来。我需要让marco循环下一行所在的工作表，直到找到一个空白单元格然后停止。

示例原始工作表将具有：

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行，依此类推，然后当宏遇到原始工作表中的ablank单元格时，它应该停止。

有人可以建议我这样做吗？

Answer 1

见下文。期望数据在A1和i中开始输出结果为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

Answer 2

这是你的代码，我测试了它，它运行得很好。

希望您的问题现在清楚。

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

如果需要更多帮助，请告诉我。

Answer 3

让我们假设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

这有帮助吗？我不确定你用什么代码来分割行。显示的样本似乎已经过卷积，可以缩小。

Answer 4

很难描绘出你真正需要做的事情。所以我坚持这个要求 - 你想要一行并从中创建两行

查看以下代码和结果：

代码：

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

结果：

enter image description here

如果你能在新的双排行中更清楚地了解你需要什么，我很乐意帮助你。

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

4 个答案: