从过滤表中复制粘贴可见单元格，需要修改代码。

Question

我写了这段代码，直到现在还能用，我对VBA还是比较陌生的，现在修改代码有问题，我把两个 AutoFilter 以拉出某些行，但我似乎无法解决如何只复制和粘贴可见行，我已经尝试了

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

复制单元格，但我得到一个错误。所需对象

谁能帮我修改一下代码，我只需要将可见单元格复制粘贴到新的工作表中即可？

可能是我遗漏了一些非常简单的东西。

下面是我的代码。

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

谢谢你的帮助

Answer 1

你不能使用 Set 和 .Copy 一行。

首先你需要设置你的可见单元格范围。

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

然后你需要测试是否找到了可见单元格 如果找到了，就可以复制它们了

If Not TempRng Is Nothing Then
    TempRng.Copy
    'all code that relies on the copied range `TempRng` needs to go here
Else
    MsgBox "No visible cells found!"
End If

Answer 2

我根据@PEH的建议重写了代码，结果成功了，请看下面的新代码。

   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