在excel中将一行拆分为两行

我需要根据行中某个标志的值将一行拆分为两行。结构如下：-

Exp_id  Flag_1 guar_percent
aaaa    Y   20
bbbb    N   0
cccc    Y   100
dddd    Y   90

---

在上述所有行中，所有标记为“Y”且guar_percent>0的行，如果您将输入范围设置为数组并进行处理，则这应该是一个相对轻松的练习。下面的代码已被彻底注释，但如果没有意义，请告诉我

Option Explicit

Sub SortData()
    Dim vInData As Variant, vOutData As Variant
    Dim ii As Long, lCounter As Long
    Dim wkOut As Worksheet

    'Read in your data, you could set this as a function and pass it any range
    vInData = ActiveSheet.Range("A1:C8").Value2

    'Double up the output array just in case every record is valid, we can redim after processing
    'Also not we've transposed the array because you can only redim preserve the second bound
    ReDim vOutData(LBound(vInData, 2) To UBound(vInData, 2), LBound(vInData, 1) To 2 * UBound(vInData, 1))

    'Loop through the input
    For ii = LBound(vInData, 1) To UBound(vInData, 1)
        'Check for the yes flag first
        If vInData(ii, 2) = "Y" Then
            'Then check the percentage bounds
            If vInData(ii, 3) > 0 And vInData(ii, 3) < 100 Then
                'Increase the counter by two since we're adding two lines.
                lCounter = lCounter + 2
                vOutData(1, lCounter - 1) = vInData(ii, 1) & "_G"
                vOutData(2, lCounter - 1) = "Y"
                vOutData(3, lCounter - 1) = 100
                vOutData(1, lCounter) = vInData(ii, 1) & "_NG"
                vOutData(2, lCounter) = "Y"
                vOutData(3, lCounter) = 0
            End If
        End If
    Next ii

    'Now we have all the outputs redim the array to remove empty elements
    ReDim Preserve vOutData(LBound(vOutData, 1) To UBound(vOutData, 1), LBound(vOutData, 2) To lCounter)

    'I've just dumped the output onto a fresh sheet, you can set the output array to any range on any worksheet you like
    Set wkOut = ThisWorkbook.Worksheets.Add
    With wkOut
        .Name = "Output"
        .Range(.Cells(1, 1), .Cells(UBound(vOutData, 2), UBound(vOutData, 1))).Value2 = Application.WorksheetFunction.Transpose(vOutData)
    End With
End Sub

选项显式
子排序数据（）
Dim vInData作为变量，vOutData作为变量
Dim ii的长度与L计数器的长度相同
将工作输出设置为工作表
'读入数据后，可以将其设置为函数，并将其传递到任何范围
vInData=ActiveSheet.Range（“A1:C8”）。值2
'将输出数组加倍，以防每个记录都有效，我们可以在处理后重新输入
'也不是，我们已经转置了数组，因为您只能保留第二个边界
重拨vOutData（LBound（vInData，2）到UBound（vInData，2），LBound（vInData，1）到2*UBound（vInData，1））
'循环输入
对于ii=LBound（vInData，1）到UBound（vInData，1）
'首先检查yes标志
如果vInData（ii，2）=“Y”，则
'然后检查百分比界限
如果vInData（ii，3）>0且vInData（ii，3）<100，则
'将计数器增加两行，因为我们要添加两行。
l计数器=l计数器+2
vOutData（1，l计数器-1）=vInData（ii，1）和“\u G”
vOutData（2，L计数器-1）=“Y”
vOutData（3，l计数器-1）=100
vOutData（1，L计数器）=vInData（ii，1）和“NG”
vOutData（2，L计数器）=“Y”
vOutData（3，lCounter）=0
如果结束
如果结束
下一个ii
'现在，我们有了所有的输出重新分配数组以删除空元素
重拨保留vOutData（LBound（vOutData，1）到UBound（vOutData，1），LBound（vOutData，2）到lCounter）
我刚刚将输出转储到一个新的工作表上，您可以将输出数组设置为任何工作表上的任意范围
Set wkOut=thiswoolk.Worksheets.Add
带着wkOut
.Name=“输出”
.Range（.Cells（1,1），.Cells（UBound（vOutData，2），UBound（vOutData，1）））.Value2=Application.WorksheetFunction.Transpose（vOutData）
以
端接头

这就是我所做的，而且很有效。欢迎提出任何优化建议。谢谢大家

Sub SplitRec()
    Dim getRow As Long
    Dim LR As Long
    Dim RowCount As Integer

    For getRow = 1 To Worksheets("Sheet1").UsedRange.Rows.Count Step 1

         If (Worksheets("Sheet1").Cells(getRow, 111).Value) > 0 And (Worksheets("Sheet1").Cells(getRow, 111).Value) < 1 Then

            Worksheets("Sheet1").Rows(getRow).Copy Worksheets("Sheet2").Rows(Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 2).End(xlUp).Row + 1)
            Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Value = Worksheets("Sheet1").Range("A" & getRow).Value + "_G"

            Worksheets("Sheet1").Rows(getRow).Copy Worksheets("Sheet2").Rows(Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 2).End(xlUp).Row + 1)
            Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Value = Worksheets("Sheet1").Range("A" & getRow).Value + "_NG"

        Else
            RowCount = RowCount + 1

            Worksheets("Sheet1").Rows(getRow).Copy Worksheets("Sheet2").Rows(Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 2).End(xlUp).Row + 1)
            Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Value = Worksheets("Sheet1").Range("A" & getRow).Value

        End If
    Next

End Sub

Sub-SplitRec（）
长得一样
变暗LR为长
将行计数设置为整数
对于getRow=1到工作表（“Sheet1”）。使用Drange.Rows.Count步骤1
如果（工作表（“Sheet1”）.单元格（getRow，111）.Value）大于0且（工作表（“Sheet1”）.单元格（getRow，111）.Value）小于1，则
工作表（“Sheet1”）。行（getRow）。复制工作表（“Sheet2”）。行（工作表（“Sheet2”）。单元格（工作表（“Sheet2”）。行数，2）。结束（xlUp）。行数+1）
工作表（“Sheet2”）.Range（“A”和Rows.Count）.End（xlUp）.Value=工作表（“Sheet1”）.Range（“A”和getRow）.Value+“\u G”
工作表（“Sheet1”）。行（getRow）。复制工作表（“Sheet2”）。行（工作表（“Sheet2”）。单元格（工作表（“Sheet2”）。行数，2）。结束（xlUp）。行数+1）
工作表（“Sheet2”）.Range（“A”和Rows.Count）.End（xlUp）.Value=工作表（“Sheet1”）.Range（“A”和getRow）.Value+“\u NG”
其他的
RowCount=RowCount+1
工作表（“Sheet1”）。行（getRow）。复制工作表（“Sheet2”）。行（工作表（“Sheet2”）。单元格（工作表（“Sheet2”）。行数，2）。结束（xlUp）。行数+1）
工作表（“Sheet2”）.Range（“A”和Rows.Count）.End（xlUp）.Value=工作表（“Sheet1”）.Range（“A”和getRow）.Value
如果结束
下一个
端接头

不要在excel中执行此操作。在生成excel的任何地方都要这样做…可能他有excel“报告”格式的输出数据，而原始源中不再存在这些数据。第二个表将位于不同的选项卡/工作簿中。已收到数百万条记录，其中50万条记录的标志_1为“Y”。任何自动化此过程的建议。我们无法控制源文件（本例中的第一个表）中的数据。为什么公司坚持以Excel格式存储数据，将网络访问权限用作伪数据库？？？从以下答案开始：

Sub SplitRec()
    Dim getRow As Long
    Dim LR As Long
    Dim RowCount As Integer

    For getRow = 1 To Worksheets("Sheet1").UsedRange.Rows.Count Step 1

         If (Worksheets("Sheet1").Cells(getRow, 111).Value) > 0 And (Worksheets("Sheet1").Cells(getRow, 111).Value) < 1 Then

            Worksheets("Sheet1").Rows(getRow).Copy Worksheets("Sheet2").Rows(Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 2).End(xlUp).Row + 1)
            Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Value = Worksheets("Sheet1").Range("A" & getRow).Value + "_G"

            Worksheets("Sheet1").Rows(getRow).Copy Worksheets("Sheet2").Rows(Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 2).End(xlUp).Row + 1)
            Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Value = Worksheets("Sheet1").Range("A" & getRow).Value + "_NG"

        Else
            RowCount = RowCount + 1

            Worksheets("Sheet1").Rows(getRow).Copy Worksheets("Sheet2").Rows(Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 2).End(xlUp).Row + 1)
            Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Value = Worksheets("Sheet1").Range("A" & getRow).Value

        End If
    Next

End Sub