import sheet based on partial file name

jordanburch

Active Member
Joined
Jun 10, 2016
Messages
373
Office Version
  1. 2016
Hey Guys,

I have the below. It works, but I need it to import based on a partial filename and I cant seem how to complete it.

Basically I want it to import the sheet if it has the text "Cleared" in it. Its erroring out because some are named Cleared - Cleared to and some are named Cleared-Cleared To ect ect. Any help is greatly appreciated! Based on partial sheet name not partial file name rather!

Jordan

Sub AllFiles()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
folderPath = "C:\Users\jordan.burch.ctr\Desktop\Cert Statements\" 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xls*")
Do While Filename <> ""

Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
Worksheets("Cleared - Cleared To").Range("a2:AU" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Workbooks("Certification statement automation").Worksheets("Cleared").Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial
Workbooks(Filename).Close True
Filename = Dir
Loop
applications.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,003
Try replacing:
VBA Code:
Worksheets("Cleared - Cleared To").Range("a2:AU" & Range("A" & Rows.Count).End(xlUp).Row).Copy
with:
VBA Code:
    Dim ws As Worksheet
    Dim ClearedSheet As String
    For Each ws In ActiveWorkbook.Worksheets
        If InStr(1, ws.Name, "Cleared", vbTextCompare) Then
            ClearedSheet = ws.Name
            Exit For
        End If
    Next
    ActiveWorkbook.Worksheets(ClearedSheet).Range("a2:AU" & Range("A" & Rows.Count).End(xlUp).Row).Copy
 

jordanburch

Active Member
Joined
Jun 10, 2016
Messages
373
Office Version
  1. 2016
Try replacing:
VBA Code:
Worksheets("Cleared - Cleared To").Range("a2:AU" & Range("A" & Rows.Count).End(xlUp).Row).Copy
with:
VBA Code:
    Dim ws As Worksheet
    Dim ClearedSheet As String
    For Each ws In ActiveWorkbook.Worksheets
        If InStr(1, ws.Name, "Cleared", vbTextCompare) Then
            ClearedSheet = ws.Name
            Exit For
        End If
    Next
    ActiveWorkbook.Worksheets(ClearedSheet).Range("a2:AU" & Range("A" & Rows.Count).End(xlUp).Row).Copy
awesome John You are a certified GENIUS! now I loop through and discovered a new issue. The sheet may or may not be in the workbook. Can you help me add code to account for if the sheet exists then do the rest and if not move on to the next file?
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,003
Insert before the For Each ws loop:
VBA Code:
    ClearedSheet = ""
and replace:
VBA Code:
ActiveWorkbook.Worksheets(ClearedSheet).Range("a2:AU" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Workbooks("Certification statement automation").Worksheets("Cleared").Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial
with:
VBA Code:
    If ClearedSheet <> "" Then
        ActiveWorkbook.Worksheets(ClearedSheet).Range("a2:AU" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        Workbooks("Certification statement automation").Worksheets("Cleared").Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial
    End If
 

jordanburch

Active Member
Joined
Jun 10, 2016
Messages
373
Office Version
  1. 2016
Insert before the For Each ws loop:
VBA Code:
    ClearedSheet = ""
and replace:
VBA Code:
ActiveWorkbook.Worksheets(ClearedSheet).Range("a2:AU" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Workbooks("Certification statement automation").Worksheets("Cleared").Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial
with:
VBA Code:
    If ClearedSheet <> "" Then
        ActiveWorkbook.Worksheets(ClearedSheet).Range("a2:AU" & Range("A" & Rows.Count).End(xlUp).Row).Copy
        Workbooks("Certification statement automation").Worksheets("Cleared").Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial
    End If
awesome thanks! One more question it keeps throwing and error code 1004 pastespecial failed? it seems to happen on only certain files and not all files. Any ideas?
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,003
Does it occur only with .xls files or only .xlsx files? Is the destination workbook a .xls or a .xlsx/.xlsm file? The 2 versions have different Rows.Count (maximum number of rows) values

Try replacing the PasteSpecial line with:
VBA Code:
With Workbooks("Certification statement automation").Worksheets("Cleared")
    .Range("A" & .Range("A" & .Rows.Count).End(xlUp).Row + 1).PasteSpecial
End With
so that .Rows.Count is always correct, regardless of the Excel file type.
 

Forum statistics

Threads
1,141,818
Messages
5,708,763
Members
421,588
Latest member
Wawie

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top