VBA, перенести определенные столбцы на новый лист

Question

У меня есть следующий код, который переводит учащегося на другой лист, если он задерживается. Студент задерживается, если период зачисления составляет 132 или менее для студента магистра и 130 и менее для студента бакалавриата. Этот код копирует все заголовки и переносит все столбцы и данные на новый лист, если ученик задерживается. Мне нужны только данные из столбцов A, B, D, G, H, I, M и поместить их на новый лист в столбцы A, B, C, D, E, F, G, если студент задерживается. Как я должен изменить этот код, чтобы он сделал это? Заранее спасибо!

Sub findDelayedStudents()

Dim wsIn As Worksheet
Dim wsOut As Worksheet


Set wsIn = ThisWorkbook.Worksheets("Base")
Set wsOut = ThisWorkbook.Worksheets("Delayed Students")


wsOut.Cells.ClearContents
wsIn.Rows(1).Copy Destination:=wsOut.Range("A1")

Dim lLastInputRow As Long
Dim lCurrentInputRow As Long
Dim lCurrentOutputRow As Long


lLastInputRow = wsIn.Cells(wsIn.Rows.Count, 1).End(xlUp).Row
lCurrentOutputRow = 2


For lCurrentInputRow = lLastInputRow To 2 Step -1

If (wsIn.Cells(lCurrentInputRow, 10) = "B" And wsIn.Cells(lCurrentInputRow, 
5).Value <= 130) Or _
    (wsIn.Cells(lCurrentInputRow, 10) = "M" And wsIn.Cells(lCurrentInputRow, 
5).Value <= 132) Then


    wsIn.Rows(lCurrentInputRow).Copy 
Destination:=wsOut.Cells(lCurrentOutputRow, 1)
    lCurrentOutputRow = lCurrentOutputRow + 1
End If
Next lCurrentInputRow

wsIn.Range("A1").Select
Set wsIn = Nothing
Set wsOut = Nothing

End Sub

Answer 1

В настоящее время вы копируете целые строки, используя встроенные методы копирования и вставки в этой части кода:

wsIn.Rows(lCurrentInputRow).Copy 
Destination:=wsOut.Cells(lCurrentOutputRow, 1)
lCurrentOutputRow = lCurrentOutputRow + 1

Было бы проще заменить это репликацией ваших значений по клеткам следующим образом:

wsOut.Cells(lCurrentOutputRow,1) = wsIn.Cells(lCurrentInputRow,1) 'A to A
wsOut.Cells(lCurrentOutputRow,2) = wsIn.Cells(lCurrentInputRow,2) 'B to B
wsOut.Cells(lCurrentOutputRow,3) = wsIn.Cells(lCurrentInputRow,4) 'D to C
wsOut.Cells(lCurrentOutputRow,4) = wsIn.Cells(lCurrentInputRow,7) 'G to D
wsOut.Cells(lCurrentOutputRow,5) = wsIn.Cells(lCurrentInputRow,8) 'H to E
wsOut.Cells(lCurrentOutputRow,6) = wsIn.Cells(lCurrentInputRow,9) 'I to F
wsOut.Cells(lCurrentOutputRow,7) = wsIn.Cells(lCurrentInputRow,13) 'M to G
lCurrentOutputRow = lCurrentOutputRow + 1

Чтобы установить правильные заголовки, замените эту часть вашего кода:

wsIn.Rows(1).Copy Destination:=wsOut.Range("A1")

С:

wsOut.Cells(1,1) = wsIn.Cells(1,1) 'A to A
wsOut.Cells(1,2) = wsIn.Cells(1,2) 'B to B
wsOut.Cells(1,3) = wsIn.Cells(1,4) 'D to C
wsOut.Cells(1,4) = wsIn.Cells(1,7) 'G to D
wsOut.Cells(1,5) = wsIn.Cells(1,8) 'H to E
wsOut.Cells(1,6) = wsIn.Cells(1,9) 'I to F
wsOut.Cells(1,7) = wsIn.Cells(1,13) 'M to G