code not importing one sheet

jordanburch

Active Member
Joined
Jun 10, 2016
Messages
439
Office Version
  1. 2016
hey guys,

I have the following code that is messing up. It needs to search for each worksheet name and then import that worksheet. The issue is that one workbook has two worksheets that need to be imported and its not importing both worksheets because I think it finds it and then closes the file and then moves to the next file. Can you help me have it search each file for each worksheet name and import all the data?

VBA Code:
Sub DRPimport1()
Dim MyFile As String
Dim erow As Long
Dim Filepath As String
Dim wb1 As Workbook, wb2 As Workbook

    Dim data_wbk2 As String
    Dim data_wbk6 As String
   
   
    Dim fn As String
    Dim fn2 As String
    Dim fn3 As String
    Dim ShtName1 As String
    Dim ShtName2 As String
    Dim ShtName3 As String
    Dim ShtName4 As String
   
    ShtName1 = "Details"
    ShtName2 = "Detail"
    ShtName3 = "Detail - DRP"
    ShtName4 = "Detail - DRP Reversal"
   
    data_wbk2 = InputBox("Enter month I.E. 08-MAY20", Default:="08-MAY20")
    data_wbk6 = InputBox("Enter month Name I.E. YYYYMM:", Default:="202005")

fn = Left(data_wbk2, 6)
fn2 = Right(data_wbk2, 2)
fn3 = Right(data_wbk6, 2)
Application.ScreenUpdating = False
Worksheets.Add.Name = "DRP"
Set wb1 = ThisWorkbook

MsgBox "K:\SHARED\TRANSFER\Enterprise Wide Suspense Initiative\DRP\" & "20" & fn2 & " " & "DRP" & "\" & "20" & fn2 & "-" & fn3 & " " & "Reporting Cycle" & "\"""

Filepath = "K:\SHARED\TRANSFER\Enterprise Wide Suspense Initiative\DRP\" & "20" & fn2 & " " & "DRP" & "\" & "20" & fn2 & "-" & fn3 & " " & "Reporting Cycle" & "\"
'K:\SHARED\TRANSFER\Enterprise Wide Suspense Initiative\DRP\2020 DRP\2020-05 Reporting Cycle
MyFile = Dir(Filepath & "*.xls*")
Do While Len(MyFile) > 0 And MyFile <> "suspense automation.xlsm"

    erow = wb1.Sheets("DRP").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Set wb2 = Workbooks.Open(Filepath & MyFile)
    With wb2
   
   
    Dim ShtName As String
ShtName = "Sheet 1"
If Evaluate("isref('" & ShtName & "'!A1)") Then
   'sheet exists do something
Else
   'sheet doesn't exist do something else
End If
   If Evaluate("isref('" & ShtName1 & "'!A1)") Then
   .Sheets("Details").AutoFilterMode = False
        .Sheets("Details").Range("d2:af1000").Copy Destination:=wb1.Worksheets("DRP").Cells(erow, 1)
        .Close savechanges:=False
        ElseIf Evaluate("isref('" & ShtName3 & "'!A1)") Then
        .Sheets("Detail - DRP").AutoFilterMode = False
        .Sheets("Detail - DRP").Range("c2:af1000").Copy Destination:=wb1.Worksheets("DRP").Cells(erow, 1)
        .Close savechanges:=False
       
        ElseIf Evaluate("isref('" & ShtName2 & "'!A1)") Then
        .Sheets("Detail").AutoFilterMode = False
        .Sheets("Detail").Range("c2:af1000").Copy Destination:=wb1.Worksheets("DRP").Cells(erow, 1)
        .Close savechanges:=False
       
        ElseIf Evaluate("isref('" & ShtName4 & "'!A1)") Then
        .Sheets("Detail - DRP Reversal").AutoFilterMode = False
        .Sheets("Detail - DRP Reversal").Range("c2:af1000").Copy Destination:=wb1.Worksheets("DRP").Cells(erow, 1)
        .Close savechanges:=False
       
       
        End If
       
       
       
    End With
    MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub

Any helps is appreciated!

Jordan
 
Last edited:

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
I cant test so try on a copy workbook first:

VBA Code:
Function SheetExists(sSheet As String, wb As Workbook) As Boolean

For Each sh In wb.Worksheets
    If LCase(CStr(sh.Name)) = LCase(sSheet) Then
        SheetExists = True
        Exit Function
    End If
Next
SheetExists = False

End Function

Sub DRPimport1()

Dim MyFile As String, Filepath As String, data_wbk2 As String, data_wbk6 As String
Dim wb1 As Workbook, wb2 As Workbook
Dim erow As Long, i As Long
Dim fn As String, fn2 As String, fn3 As String
Dim shArr
   
Application.ScreenUpdating = False

shArr = Array("Details", "Detail", "Detail - DRP", "Detail - DRP Reversal")
data_wbk2 = InputBox("Enter month I.E. 08-MAY20", Default:="08-MAY20")
data_wbk6 = InputBox("Enter month Name I.E. YYYYMM:", Default:="202005")
fn = Left(data_wbk2, 6)
fn2 = Right(data_wbk2, 2)
fn3 = Right(data_wbk6, 2)

If Not SheetExists("DRP", ThisWorkbook) Then Worksheets.Add.Name = "DRP"

Filepath = "K:\SHARED\TRANSFER\Enterprise Wide Suspense Initiative\DRP\20" & fn2 & " DRP\20" & fn2 & "-" & fn3 & " Reporting Cycle\"
MyFile = Dir(Filepath & "*.xls*")
Do While Len(MyFile) > 0 And MyFile <> "suspense automation.xlsm"
    Set wb2 = Workbooks.Open(Filepath & MyFile)
    With wb2
        For i = LBound(shArr) To UBound(shArr)
            If SheetExists(CStr(shArr(i)), wb2) Then
                erow = ThisWorkbook.Sheets("DRP").Range("A" & Rows.Count).End(xlUp).Row + 1
                With .Sheets(shArr(i))
                    If .AutoFilterMode = True Then .AutoFilterMode = False
                    .Range("D2:AF1000").Copy Destination:=ThisWorkbook.Worksheets("DRP").Cells(erow, 1)
                End With
            End If
        Next
        .Close savechanges:=False
    End With
    MyFile = Dir
Loop

Application.ScreenUpdating = True

End Sub
 
Upvote 0
Solution
I cant test so try on a copy workbook first:

VBA Code:
Function SheetExists(sSheet As String, wb As Workbook) As Boolean

For Each sh In wb.Worksheets
    If LCase(CStr(sh.Name)) = LCase(sSheet) Then
        SheetExists = True
        Exit Function
    End If
Next
SheetExists = False

End Function

Sub DRPimport1()

Dim MyFile As String, Filepath As String, data_wbk2 As String, data_wbk6 As String
Dim wb1 As Workbook, wb2 As Workbook
Dim erow As Long, i As Long
Dim fn As String, fn2 As String, fn3 As String
Dim shArr
  
Application.ScreenUpdating = False

shArr = Array("Details", "Detail", "Detail - DRP", "Detail - DRP Reversal")
data_wbk2 = InputBox("Enter month I.E. 08-MAY20", Default:="08-MAY20")
data_wbk6 = InputBox("Enter month Name I.E. YYYYMM:", Default:="202005")
fn = Left(data_wbk2, 6)
fn2 = Right(data_wbk2, 2)
fn3 = Right(data_wbk6, 2)

If Not SheetExists("DRP", ThisWorkbook) Then Worksheets.Add.Name = "DRP"

Filepath = "K:\SHARED\TRANSFER\Enterprise Wide Suspense Initiative\DRP\20" & fn2 & " DRP\20" & fn2 & "-" & fn3 & " Reporting Cycle\"
MyFile = Dir(Filepath & "*.xls*")
Do While Len(MyFile) > 0 And MyFile <> "suspense automation.xlsm"
    Set wb2 = Workbooks.Open(Filepath & MyFile)
    With wb2
        For i = LBound(shArr) To UBound(shArr)
            If SheetExists(CStr(shArr(i)), wb2) Then
                erow = ThisWorkbook.Sheets("DRP").Range("A" & Rows.Count).End(xlUp).Row + 1
                With .Sheets(shArr(i))
                    If .AutoFilterMode = True Then .AutoFilterMode = False
                    .Range("D2:AF1000").Copy Destination:=ThisWorkbook.Worksheets("DRP").Cells(erow, 1)
                End With
            End If
        Next
        .Close savechanges:=False
    End With
    MyFile = Dir
Loop

Application.ScreenUpdating = True

End Sub
thanks but its erroring out on the sh part of the function saying the variable isnt defined. compile error variable not defined.

Jordan
 
Upvote 0
Put
VBA Code:
Dim sh as worksheet
in the function.
thanks Steve! it works great. I have one more question. The ranges are the same for three sheets but different for one. If you look at my original ranges they changed. Any chance you could help me update it to just pull those ranges? when I import the data its off by one column
 
Upvote 0
This line
VBA Code:
.Range("D2:AF1000").Copy Destination:=ThisWorkbook.Worksheets("DRP").Cells(erow, 1)
could be replaced with
VBA Code:
If LCase(.Name) = "details" Then
    .Range("D2:AF1000").Copy Destination:=ThisWorkbook.Worksheets("DRP").Cells(erow, 1)
Else
    .Range("C2:AF1000").Copy Destination:=ThisWorkbook.Worksheets("DRP").Cells(erow, 1)
End If
 
Upvote 0
This line
VBA Code:
.Range("D2:AF1000").Copy Destination:=ThisWorkbook.Worksheets("DRP").Cells(erow, 1)
could be replaced with
VBA Code:
If LCase(.Name) = "details" Then
    .Range("D2:AF1000").Copy Destination:=ThisWorkbook.Worksheets("DRP").Cells(erow, 1)
Else
    .Range("C2:AF1000").Copy Destination:=ThisWorkbook.Worksheets("DRP").Cells(erow, 1)
End If
you sir are a gentleman and a scholar! (yes the two can coexist haha) Thanks a bunch!

Jordan
 
Upvote 0
This line
VBA Code:
.Range("D2:AF1000").Copy Destination:=ThisWorkbook.Worksheets("DRP").Cells(erow, 1)
could be replaced with
VBA Code:
If LCase(.Name) = "details" Then
    .Range("D2:AF1000").Copy Destination:=ThisWorkbook.Worksheets("DRP").Cells(erow, 1)
Else
    .Range("C2:AF1000").Copy Destination:=ThisWorkbook.Worksheets("DRP").Cells(erow, 1)
End If
I have one more request. Can you help me import the file name concatenated with the sheet name on the first empty column to the right for each file? its not working right since I need to identify each file name.

Jorda
 
Upvote 0

Forum statistics

Threads
1,213,537
Messages
6,114,216
Members
448,554
Latest member
Gleisner2

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
Back
Top