複製和使用VBA

Question

我有這樣的格式的數據集直接粘貼下一行：

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 

Answer 1

這個怎麼樣？

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逐行瀏覽它是如何工作的！