使用VBA將一行從一張紙複製到另一張

Question

我有兩張包含員工記錄的工作表。 Sheet1中包含事件日期，CardNo，員工姓名，部門編號，員工號，進入和退出時間，累計工作時間，狀態，ConcatinatedColumn和備註

Sheet2中包含ConcatinatedColumn，活動日期（通過從Sheet2的VLOOKUP複製），員工號，姓名，備註。

如果sheet2的備註欄中的數據是「Sick Off」，那麼應將該行插入Sheet1而不影響以前的記錄。

我已經爲它編寫了代碼，但它不起作用。

如果有人能幫助我，我會很感激！

感謝提前！

我的代碼：

Sub SickOff() 

Dim objWorksheet As Sheet2 
Dim rngBurnDown As Range 
Dim rngCell As Range 
Dim strPasteToSheet As String 

'Used for the new worksheet we are pasting into 
Dim objNewSheet As Sheet1 

Dim rngNextAvailbleRow As Range 

'Define the worksheet with our data 
Set objWorksheet = ThisWorkbook.Worksheets("Sheet2") 


'Dynamically define the range to the last cell. 
'This doesn't include and error handling e.g. null cells 
'If we are not starting in A1, then change as appropriate 
Set rngBurnDown = objWorksheet.Range("G2:G" & objWorksheet.Cells(Rows.Count,  "G").End(xlUp).Row) 

'Now loop through all the cells in the range 
For Each rngCell In rngBurnDown.Cells 

objWorksheet.Select 

If rngCell.Value = "Sick Off" Then 
'select the entire row 
rngCell.EntireRow.Select 

'copy the selection 
Selection.Copy 

'Now identify and select the new sheet to paste into 
Set objNewSheet = ThisWorkbook.Worksheets("Sheet1" & rngCell.Value) 
objNewSheet.Select 

'Looking at your initial question, I believe you are trying to find the next  available row 
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row) 


Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select 
ActiveSheet.Paste 
End If 

Next rngCell 

objWorksheet.Select 
objWorksheet.Cells(1, 1).Select 

'Can do some basic error handing here 

'kill all objects 
If IsObject(objWorksheet) Then Set objWorksheet = Nothing 
If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing 
If IsObject(rngCell) Then Set rngCell = Nothing 
If IsObject(objNewSheet) Then Set objNewSheet = Nothing 
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing 

End Sub 

Answer 1

比方說，你在Sheet2數據如下圖所示

比方說數據的Sheet1結束看起來像這樣

邏輯：

我們正在使用自動篩選來獲得相關範圍Sheet2匹配Col GSick Off其中。一旦我們得到了，我們將數據複製到Sheet1的最後一行。在複製數據之後，我們只需將數據隨意洗牌以匹配列標題。正如你所提到的那樣，頭文件不會改變，所以我們可以自由地對列名進行硬編碼來洗牌這些數據。

代碼：

粘貼此代碼的模塊在

Option Explicit 

Sub Sample() 
    Dim wsI As Worksheet, wsO As Worksheet 
    Dim lRow As Long, wsOlRow As Long, OutputRow As Long 
    Dim copyfrom As Range 

    Set wsI = ThisWorkbook.Sheets("Sheet1") 
    Set wsO = ThisWorkbook.Sheets("Sheet2") 

    '~~> This is the row where the data will be written 
    OutputRow = wsI.Range("A" & wsI.Rows.Count).End(xlUp).Row + 1 

    With wsO 
     wsOlRow = .Range("G" & .Rows.Count).End(xlUp).Row 

     '~~> Remove any filters 
     .AutoFilterMode = False 

     '~~> Filter G on "Sick Off" 
     With .Range("G1:G" & wsOlRow) 
      .AutoFilter Field:=1, Criteria1:="=Sick Off" 
      Set copyfrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow 
     End With 

     '~~> Remove any filters 
     .AutoFilterMode = False 
    End With 

    If Not copyfrom Is Nothing Then 
     copyfrom.Copy wsI.Rows(OutputRow) 

     '~~> Shuffle data 
     With wsI 
      lRow = .Range("A" & .Rows.Count).End(xlUp).Row 

      .Range("A" & OutputRow & ":A" & lRow).Delete Shift:=xlToLeft 
      .Range("F" & OutputRow & ":F" & lRow).Copy .Range("K" & OutputRow) 
      .Range("F" & OutputRow & ":F" & lRow).ClearContents 
      .Range("B" & OutputRow & ":B" & lRow).Copy .Range("E" & OutputRow) 
      .Range("B" & OutputRow & ":B" & lRow).ClearContents 
     End With 
    End If 
End Sub 

輸出：