Макрос для копирования / вставки определенных столбцов строки в новый лист в зависимости от критериев

Question

Это мой первый пост, поэтому, пожалуйста, потерпите меня.

Я использую код (с этого сайта), который просматривает список в столбце «А» определенного листа и создает / называет новые листы из этого списка (если они еще не существуют). Он также копирует данные из строк с соответствующими именами в соответствующие листы.

Меня интересует, как изменить код так, чтобы вместо копирования всей строки на новый лист он копировал только столбцы A:P Я был бы очень признателен за любую помощь. Вот код:

Sub yearAssign()
    Application.ScreenUpdating = False
    On Error GoTo SheetError
    sheetname = "initial"
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim wks1 As Worksheet
    Set wkb = ThisWorkbook
    Set wks = Sheets(sheetname)
    totalsheets = wkb.Worksheets.Count
    For i = 1 To totalsheets
        Set wks1 = wkb.Worksheets(i)
        thename = wks1.Name
        If thename <> sheetname Then
            wks1.Rows.Clear
        End If
    Next i
    totalrows = wks.Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To totalrows
        theyear = wks.Cells(i, 1)
        Set wks1 = Sheets(theyear)
        lastrow = wks1.Cells(Rows.Count, "A").End(xlUp).Row + 1
        If lastrow = 2 Then
            wks.Rows(1).Copy Destination:=Sheets(theyear).Range("A1")
        End If
        wks.Rows(i).Copy Destination:=Sheets(theyear).Range("A" & lastrow)
    Next i
    Application.ScreenUpdating = True
    finish = MsgBox("Finished", vbInformation)

    SheetError:
    If Err.Number = 9 Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = theyear
        Resume
    End If
End Sub

Answer 1

Вот строки, которые выполняют фактическое копирование целых строк:

wks.Rows(1).Copy Destination:=Sheets(theyear).Range("A1")

wks.Rows(i).Copy Destination:=Sheets(theyear).Range("A" & lastrow)

Таким образом, изменение их следующим образом приведет к тому, что они будут копировать только столбцы A:P:

wks.Range("A1:P1").Copy Destination:=Sheets(theyear).Range("A1")

wks.Range("A" & i & ":" & "P" & i).Copy Destination:=Sheets(theyear).Range("A" & lastrow)

Кроме того, в коде есть несколько других проблем, включая, но не обязательно, следующие:

1) Многие объявления переменных отсутствуют:

Dim sheetname As String
Dim totalsheets As String
Dim theyear As String
Dim thename As String
Dim i As Integer
Dim finish As Integer
Dim totalrows As Long
Dim lastrow As Long

2) имя sheetname устанавливается перед объявлением переменных

3) Должен быть общий обработчик ошибок и Application.ScreenUpdating должен быть установлен в True при возникновении любой ошибки (в противном случае, Application.ScreenUpdating останется False когда процедура завершится после ошибки)

4) Sheets(theyear) в строках, выполняющих копирование, должны быть заменены на wks1 , потому что переменная wks1 уже была установлена в Sheets(theyear)

Обратите внимание, что указание Option Explicit в верхней части модуля поможет привлечь внимание к таким проблемам, как # 1 и # 2, так как тогда код не будет компилироваться до тех пор, пока проблемы не будут устранены.