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

-1

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

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

Меня интересует, как изменить код, чтобы вместо копирования всей строки на новый лист он копировал только столбцы 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

microsoft-excel microsoft-excel-2010 vba

— Фанк
источник

Я предлагаю вам записать свой собственный макрос. Это очень просто, нажмите запись, выполните процедуру, нажмите стоп, изучите код. Использование этого кода только расстроит вас, и это для конкретной проблемы; Вот как работает VBa - специфическая проблема. Алгоритмы можно использовать повторно, а кодирование для работы - нет.

— ejbytes

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

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, так как тогда код не будет компилироваться, пока проблемы не будут решены.

— MJH
источник