0

我有一个像这种格式的数据集：

 varname  Flag  Status
Product1    Y   
Product2    N   
Product3    N   
Product4    N   
Product5    N   
Product6    N   
Product7    Y   
Product8    Y   
Product9    Y   
Product10   Y

现在，对于任何产品标志是“Y”，那么它应该在它旁边输入一行，然后复制该行并立即粘贴到该行下方。新表应如下所示：

varname   Flag  Status
Product1    Y   
Product1    Y   SOLD
Product2    N   
Product3    N   
Product4    N   
Product5    N   
Product6    N   
Product7    Y   
Product7    Y   SOLD
Product8    Y   
Product8    Y   SOLD
Product9    Y   
Product9    Y   SOLD
Product10   Y   
Product10   Y   SOLD

此状态也应更新。我尝试了以下代码。但不幸的是，这段代码无法创建表。如果有人可以帮助我找到解决方案，我将不胜感激。

Sub RegInt2()
    Dim lngRow As Long
    Dim LR As Long
    For lngRow = Worksheets("Sheet1").UsedRange.Rows.Count To 1 Step -1
          LR = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
        If UCase$(Worksheets("Sheet1").Cells(lngRow, 2).Value) = "R" Then
            Worksheets("Sheet1").Range("A" & CStr(lngRow + 1)).Select
            Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
            End If
            If UCase$(Worksheets("Sheet1").Cells(lngRow, 2).Value) = "R" Then
            Worksheets("Sheet1").Range("A" & LR).Copy Destination:=Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1)


        End If
        Next

End Sub
4

1 回答 1

3

这个怎么样？

Sub DuplicateSoldProducts()

Dim ProductRange As Range
Dim ProductCell As Range

Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet

'create a new worksheet
Set SourceSheet = Worksheets("Products")
Set TargetSheet = Worksheets.Add

SourceSheet.Select
Range("A1").Select

'put in titles
Range(ActiveCell, ActiveCell.End(xlToRight)).Copy
TargetSheet.Select
TargetSheet.Paste

SourceSheet.Select
Application.CutCopyMode = False

'set reference to block of products
Set ProductRange = Range(ActiveCell, ActiveCell.End(xlDown))

'go through product by product
For Each ProductCell In ProductRange.Cells

    'create row (and maybe copy) on target sheet
    TargetSheet.Select
    ActiveCell.Value = ProductCell.Value
    ActiveCell.Offset(0, 1).Value = ProductCell.Offset(0, 1).Value

    'go to next cell
    ActiveCell.Offset(1, 0).Select

    If UCase(ProductCell.Offset(0, 1).Value) = "Y" Then

        'create copy?
        ActiveCell.Value = ProductCell.Value
        ActiveCell.Offset(0, 1).Value = ProductCell.Offset(0, 1).Value
        ActiveCell.Offset(0, 2).Value = "Sold"

        'go to next cell
        ActiveCell.Offset(1, 0).Select

   End If

Next ProductCell

Range("A1").CurrentRegion.EntireColumn.AutoFit
Range("A1").Select

MsgBox "Done!"

按 F8 逐行查看它是如何工作的！

于 2012-11-15T16:24:11.990 回答