使用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 

输出：