CODEWITHSUNDEEP
vbaexcel
Huỳnh Tùng
Huỳnh Tùng

Reputation: 79

Copy data from multiple workbook to one workbook after using Autofilter

I am trying to copy data from multiple WB to one WB after using filter. I am able to select the copy range but I don't know how to paste them to the destination WB without making the data overwritten.

I am sorry for the format of my code. I do not know how to fix it when I post it here.

Here is my code:

Option Explicit

Const FOLDER_PATH = "D:\Programming\VBA\Linh\CARD DELIVERY\New folder\"  'REMEMBER END BACKSLASH
Sub ImportWorksheets()
   '=============================================
   'Process all Excel files in specified folder
   '=============================================
    Dim sFile As String           'file to process
    Dim wsTarget As Worksheet
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim rowTarget As Long         'output row
    Dim rowCount As Long
    rowTarget = 2

   'check the folder exists
    If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub
    End If

   'reset application settings in event of error
    On Error GoTo errHandler
    Application.ScreenUpdating = False

   'set up the target worksheet
    Set wsTarget = Sheets("Sheet1")

   'loop through the Excel files in the folder
    sFile = Dir(FOLDER_PATH & "*.xls*")
    Do Until sFile = ""

  'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
    Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
    Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY

wsSource.Range("A2", Range("P" & Rows.Count).End(xlUp)).AutoFilter Field:=12, Criteria1:="Phát thành công"
    wsSource.Range("I2", Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
    rowCount = wsSource.Range("I2", Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells.Count

  'import the data
With wsTarget

End With

  'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
sFile = Dir()
   Loop

errHandler:
    On Error Resume Next
    Application.ScreenUpdating = True

   'tidy up
    Set wsSource = Nothing
    Set wbSource = Nothing
    Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

Upvotes: 0

Views: 108

Answers (1)

DisplayName
DisplayName

Reputation: 13386

just add:

'import the data
wsTarget
    .cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial
End With

to keep pasting filtered data in wsTarget column A from row 2 downwards

Upvotes: 1

Related Questions