Merging and renaming sheets from multiple workbooks

[rachel06]

Hello,

I'm working on the below code which right now grabs all sheets named AP35 from workbooks in a specified folder. There's two ways I want to alter this but I haven't figured out a way:

1. Instead of referencing an exact link in the code, can I have it reference a cell (I2) every month instead of having to update the code each month with the new location? It'll change quarterly.
* This line in the below code. (fd.InitialFileName = "C:\folder" ) I'm sure this part is easy!


2. The sheet names are all AP35, AP35(1), AP35(2), etc. Can I redo this in a way that will name the sheets after the file name instead? I'd love for it to match the first half of the name of the workbooks it pulls the sheet from. They all end with " Approval File", so if there's a way to have it use the original file name minus that, I'd like to know. Unfortunately, the file names have a different number of characters before that. This is my code so far:

Sub Test()
Dim fd As FileDialog
Dim FilePicked As Integer, f As Integer
Dim sWb As Workbook
Dim ws As Worksheet

Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "C:\folder"
fd.AllowMultiSelect = True
FilePicked = fd.Show

Application.ScreenUpdating = False

If FilePicked = 0 Then
Application.ScreenUpdating = True
Exit Sub
Else
For f = 1 To fd.SelectedItems.Count
Set sWb = Workbooks.Open(fd.SelectedItems(f))
For Each ws In sWb.Worksheets
If ws.Name = "AP35" Then
ws.Copy _
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
End If
Next ws
sWb.Close False
Next f
End If

Application.ScreenUpdating = True

End Sub

TIA!

Rachel

 

[JLGWhiz]

Assuming you have the file initial file path in cell I2 .

Sub TestRev()
Dim fd As FileDialog
Dim FilePicked As Integer, f As Integer
Dim sWb As Workbook
Dim ws As Worksheet
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = ActiveSheet.Range("I2").Value
fd.AllowMultiSelect = True
FilePicked = fd.Show
Application.ScreenUpdating = False
    If FilePicked = 0 Then
        Application.ScreenUpdating = True
        Exit Sub
    Else
        For f = 1 To fd.SelectedItems.Count
            Set sWb = Workbooks.Open(fd.SelectedItems(f))
                For Each ws In sWb.Worksheets
                    If ws.Name = "AP35" Then
                        ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                        Sheets(Sheets.Count).Name = Left(sWb.Name, InStr(sWb.Name, " Approval File") - 1)
                    End If
                Next ws
            sWb.Close False
        Next f
    End If
Application.ScreenUpdating = True
End Sub

 

[rachel06]

AMAZING! This worked perfectly!

Two more questions:

Is there anyway to have the code work as "contains AP35" instead of "equals AP35"?

Is there any way with the sheet name line that currently removes the words "Approval File" to also remove the first 3 characters of the file name? I forgot we're going to start adding our initials + a space at the beginning.

Thanks for your help this far! This is awesome!

 

[JLGWhiz]

Is there anyway to have the code work as "contains AP35" instead of "equals AP35"?

If InStr((wsName,  "AP35") > 0 Then

Is there any way with the sheet name line that currently removes the words "Approval File" to also remove the first 3 characters of the file name?

Sheets(Sheets.Count).Name = Mid(sWb.Name, 4, InStr(sWb.Name, " Approval File") - 4)

 

[rachel06]

The first one isn't working - Compile error: Expected: )
I've tried adding an extra bracket into a few places to try to amend this with no luck. I took out one of the first ones and the macro ran, but it literally just opened the workbooks and did nothing else.

 

[JLGWhiz]

The first one isn't working - Compile error: Expected: )
I've tried adding an extra bracket into a few places to try to amend this with no luck. I took out one of the first ones and the macro ran, but it literally just opened the workbooks and did nothing else.

The extra ( was a typo.

Post the code as you are currently attempting to use it so I can see what you are working with and make corrections , if needed.

 

[rachel06]

Sub GetAP35()
Dim fd As FileDialog
Dim FilePicked As Integer, f As Integer
Dim sWb As Workbook
Dim ws As Worksheet
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = ActiveSheet.Range("C3").Value
fd.AllowMultiSelect = True
FilePicked = fd.Show
Application.ScreenUpdating = False
If FilePicked = 0 Then
Application.ScreenUpdating = True
Exit Sub
Else
For f = 1 To fd.SelectedItems.Count
Set sWb = Workbooks.Open(fd.SelectedItems(f))
For Each ws In sWb.Worksheets

If InStr(wsName, "AP35") > 0 Then

ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Sheets(Sheets.Count).Name = Left(sWb.Name, InStr(sWb.Name, " Approval File") - 1)
End If
Next ws
sWb.Close False
Next f
End If
Application.ScreenUpdating = True
End Sub

Thanks so much!!

 

[JLGWhiz]

You had changed one of your variable names but did not make all the changes in the code. This should now work.

Sub GetAP35()
Dim fd As FileDialog
Dim FilePicked As Integer, f As Integer
Dim sWb As Workbook
Dim ws As Worksheet
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = ActiveSheet.Range("C3").Value
fd.AllowMultiSelect = True
FilePicked = fd.Show
Application.ScreenUpdating = False
    If FilePicked = 0 Then
        Application.ScreenUpdating = True
        Exit Sub
    Else
        For f = 1 To fd.SelectedItems.Count
            Set sWb = Workbooks.Open(fd.SelectedItems(f))
                For Each ws In sWb.Worksheets
                    If InStr(ws, "AP35") > 0 Then
                        ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                        Sheets(Sheets.Count).Name = Mid(sWb.Name, 4, InStr(sWb.Name, " Approval File") - 4)
                    End If
                Next ws
                sWb.Close False
        Next f
    End If
Application.ScreenUpdating = True
End Sub

 

[rachel06]

Perfect! Thanks for the explanation as well. I've been trying to learn more about VBA for the past few years now, so I appreciate the explanation along with the solution.

Thanks for your help!

 

[JLGWhiz]

Perfect! Thanks for the explanation as well. I've been trying to learn more about VBA for the past few years now, so I appreciate the explanation along with the solution.

Thanks for your help!

After over twenty years of messing with this stuff I am still learning how to use it. It is a little easier now that twenty years ago, but since I am no longer actively employed, I don't have the opportunities to really exploit the finer points of vba applications. But engaging in the forums helps me sort of keep up to date. But I am still limited in what I can efficiently write code for.
Thanks for the feedback,
Regards, JLG