Search code examples
excelvbacopy-paste

Copy/Paste Visible Cells from Filtered sheet


I have written this code and it has worked until now.

I have put two AutoFilter to pull certain rows. How do I amend the code to copy and paste visible rows?

I tried

Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy'

which copies the cells but then I get an error. Object required

Sub LoopThrough()

    Dim MyFile As String, Str As String, MyDir As String
    Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range
    Dim NewMasterLine As Long

    On Error GoTo ErrorHandler
    Set sh = ThisWorkbook.Worksheets("Sheet2")

    MyDir = "C:\Users\eldri\OneDrive\Desktop\New folder (2)\"
    MyFile = Dir(MyDir & "*.xls")
    ChDir MyDir

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Do While MyFile <> ""
      'opens excel
      Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False, 

Password:=CalcPassword(MyFile))
          Set TempSH = TempWB.Worksheets(1)
          Columns(1).Insert
          Range("c2").Copy Range("A4:A10000")
          Worksheets("Data").Range("A4").AutoFilter Field:=3, Criteria1:="AMS"
          Worksheets("Data").Range("A4").AutoFilter Field:=4, Criteria1:="XNE"
          Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row)

      NewMasterLine = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
      If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
      Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & (NewMasterLine + TempRng.Rows.Count))
      MasterRange.Value = TempRng.Value
      'Debug.Print "Imported File: " & MyFile & ", Imported Range: " & TempRng.Address & ", Destination Range: " & MasterRange.Address
      TempWB.Close savechanges:=False

      MyFile = Dir()

    Loop

MsgBox ("Done")

ErrorHandler:
    If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Solution

  • I rewrote the code with the advice from @PEH and it worked - Please find the new code below.

       Sub LoopThrough()
    
            Dim MyFile As String, Str As String, MyDir As String
            Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range, TempRow As Range
            Dim NewMasterLine As Long
    
            On Error GoTo ErrorHandler
            Set sh = ThisWorkbook.Worksheets("Sheet2")
    
            ' Change address to suite
            MyDir = "C:\Users\eldri\OneDrive\Desktop\W220Q1\"
            MyFile = Dir(MyDir & "*.xls")
            ChDir MyDir
    
            ' The following lines will put excel in a state similar to "frozen" mode. This will increase the code performance, as CPU will solely focus on performing
            ' the operations required by the code and not on showing the changes happening on excel
            Application.ScreenUpdating = False
            Application.DisplayAlerts = False
    
            ' Here starts the loop related to the files in folder
            Do While MyFile <> ""
              'TempWB is a Worksheet object - will be the importing worksheet. TempRng is the used range in sheet 1 of the workbook
              Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False, Password:=CalcPassword(MyFile))
              Columns(1).Insert
              Range("c2").Copy Range("A4:A10000")
              Set TempSH = TempWB.Worksheets(1)
    
              Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("A" & TempSH.Rows.Count).End(xlUp).Row)
    
              'NewMasterLine is the last used row (+1) of the Master Workbook (It is basically where the new rows wiill start to be imported)
              NewMasterLine = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
              If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
    
              'This will loop through all the rows of the range to be imported, checking the first column.
              ' If the value in the second column is work-xne-ams, will import the single row in the master worklbook
              For Each TempRow In TempRng.Rows
                If TempRow.Cells(1, 3).Value = "AMS" And TempRow.Cells(1, 4).Value = "XNE" Or TempRow.Row < 4 Then
                  Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & NewMasterLine)
                  MasterRange.Value = TempRow.Value
                  NewMasterLine = NewMasterLine + 1
                End If
              Next
    
              TempWB.Close savechanges:=False
              MyFile = Dir()
    
            Loop
    
        MsgBox ("Done")
    
    
        ErrorHandler:
            If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
            Application.ScreenUpdating = True
            Application.DisplayAlerts = True
        End Sub
    
        Function CalcPassword(FileName As String) As String
          CalcPassword = ""
          On Error Resume Next
          Dim TheFile As String: TheFile = Split(Split(FileName, "\")(UBound(Split(FileName, "\"))), ".")(0)
          Dim PWD As Range: Set PWD = ThisWorkbook.Worksheets("PWD").ListObjects("PWD").DataBodyRange
          CalcPassword = WorksheetFunction.VLookup(TheFile, PWD, 5, False)
        End Function