如何根據條件復制基於行值的粘貼數據

Question

我目前有一個數據集，如下所示：

         A     B     C     D     E     F     G 
     1   x     x     x     x     x     x     *
     2   a     a     a     a     a     a     
     3   c     c     c     c     c     c     %

我需要的代碼粘貼行的數據集的基礎上，底部的副本，如果有一個在文本column 。 然后，我需要column G的文本出現在column F而該行中的所有其他內容保持不變。 例如，結果將是：

        A     B     C     D     E     F     G
    1   x     x     x     x     x     x     *
    2   a     a     a     a     a     a     
    3   c     c     c     c     c     c     %
    4   x     x     x     x     x     *
    5   c     c     c     c     c     %

我的代碼當前如下所示：

Public Sub CopyRows()
     Sheets("Exposure Distribution").Select
     ' Find the last row of data
     FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
     ' Loop through each row
     For x = 2 To FinalRow
        ' Decide if to copy based on column H
        ThisValue = Cells(x, 8).Value
        If Application.WorksheetFunction.IsText(ThisValue) = "True" Then
            Cells(x, 1).Resize(1, 33).Copy
            Sheets("Exposure Distribution").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow, 1).Select
            ActiveSheet.Paste
            Sheets("Exposure Distribution").Select
        End If
        ThisValue = Cells(x, 9).Value
        If Application.WorksheetFunction.IsText(ThisValue) = "True" Then
            Cells(x, 1).Resize(1, 33).Copy
            Sheets("Exposure Distribution").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow, 1).Select
            ActiveSheet.Paste
            Sheets("Exposure Distribution").Select
        End If
       ThisValue = Cells(x, 10).Value
        If Application.WorksheetFunction.IsText(ThisValue) = "True" Then
            Cells(x, 1).Resize(1, 33).Copy
            Sheets("Exposure Distribution").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow, 1).Select
            ActiveSheet.Paste
            Sheets("Exposure Distribution").Select
        End If
     Next x
End Sub


However I don't know how to accomplish the final part of what I'm looking for, which is moving data from column G to column F based on if there's text in `column G`.

Answer 1

看看這是否有幫助：

Sub CopyPasteWithConditions()

Dim wb As Workbook: Set wb = ActiveWorkbook 'declare and set the workbook
Dim ws As Worksheet: Set ws = wb.Sheets("SheetNameHere") 'declare and set the worksheet

Dim lRow As Long: lRow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'get the last row of current data
Dim cntTxts As Long: cntTxts = WorksheetFunction.CountA(Range("G1:G" & lRow)) 'get the number of times there is any text in G


Dim arrData As Variant: arrData = ws.Range("A1:G" & lRow + cntTxts) 'create an array of current data + number of rows required for the copied data

Dim R As Long, C As Long, X As Long
For R = LBound(arrData) To lRow 'for each row in current data
    If arrData(R, 7) <> "" Then 'if there is any text in G
        X = X + 1
        For C = LBound(arrData, 2) To UBound(arrData, 2) - 1 'for each column in data, except last
            If C = 6 Then 'if we are on the last column, get the extra text instead
                arrData(lRow + X, C) = arrData(R, 7) 'add the value to the row equal to last row + value of X (pretty much the next free row)
            Else 'else the other values
                arrData(lRow + X, C) = arrData(R, C) 'add the value to the row equal to last row + value of X (pretty much the next free row)
            End If
        Next C
    End If
Next R

ws.Range("A1:G" & lRow + cntTxts) = arrData 'put the data back on the sheet

End Sub