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

Question

У меня есть рабочий макрос VBA, который копирует из одной таблицы «AverageEarnings» в другую «Sheet1», при условии, что в столбце AO есть слово «UNGRADED». Макрос копирует все эти условные строки в Sheet1. Я хочу скопировать столбцы B и C («Средние оценки») в столбцы A и B ('Sheet1'). Как изменить это.

Sub UngradedToSHEET1() 

' UngradedToSHEET1 Macro 
' 
    Dim wb1 As Workbook, wb2 As Workbook 
    Dim ws1 As Worksheet, ws2 As Worksheet 
    Dim copyFrom As Range 
    Dim lRow As Long 
    Dim stringToFind As String 

    Set wb1 = ThisWorkbook 
    Set ws1 = wb1.Worksheets("AverageEarnings") 

    stringToFind = "UNGRADED" 

    With ws1 
     'Remove all filters from spreadsheet to prevent loss of information. 
     .AutoFilterMode = False 
     lRow = .Range("AO" & .Rows.Count).End(xlUp).Row 'Find a specific column. 

     With .Range("AO1:AO" & lRow) ' This is the row where GRADED or UNGRADED is specified. 
      .AutoFilter Field:=1, Criteria1:="=*" & stringToFind & "*" 'Filter specific information. 
      Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow 
     End With 

     'Remove spreadsheet filters again. 
     .AutoFilterMode = False 
    End With 

    Set ws2 = wb1.Worksheets("Sheet1") 

    With ws2 
     If Application.WorksheetFunction.CountA(.Cells) <> 0 Then ' Find a blank row after A1. 
      lRow = .Cells.Find(What:="*", _ 
          After:=.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
     Else 
      lRow = 1 
     End If 
     copyFrom.Copy .Rows(lRow) 
    End With 
End Sub 

Answer 1

Эта строка копирует весь ряд:

Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow

Вам нужно будет изменить EntireRow, чтобы просто скопировать столбцы, которые вы хотите, вероятно, что-то вроде:

Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Range(.Cells(1,2),.Cells(1,3))

Надеюсь, это поможет, я не могу проверить это прямо сейчас.