Скопируйте строку из одного листа в другой с помощью VBA

Question

У меня есть два листа, содержащие записи сотрудников. Лист1 содержит Дату События, CardNo, Имя сотрудника, Dept Id, сотрудник Нет, вход и выход время, Общие рабочее время, статус, ConcatinatedColumn и замечание (скопированы через ВПР из sheet2)

Sheet2 содержит ConcatinatedColumn, дату события, Сотрудник Нет, Имя, Примечания.

Если данные в столбце примечаний листа 2 являются «Sick Off», то эта строка должна быть вставлена ​​в лист1 без выполнения предыдущих записей.

Я уже написал для него код, но он не работает.

Был бы очень благодарен, если кто-нибудь может мне помочь!

СПАСИБО В РАМКАХ!

МОЙ КОД:

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 который соответствует Sick Off в Col G. Как только мы получим это, мы скопируем данные в последнюю строку в 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 

Выход: