how make this code more dynamically (loop all files in the same directory )

[abdelfattah]

hi experts

I have this code import specific sheet to closed file . now I have many files in the same directory what I want import specific sheets ( sh1,imp, ex ,ret) from multiple files in the same directory . it should search for theses sheets in all files and import the data to closed file.
any suggestion to do that,please?

Sub CopySheetToClosedWB()
Dim SourceSht As Worksheet
Set SourceSht = Sheets("sheet2")
Application.ScreenUpdating = False
Set closedBook = Workbooks.Open("C:\Users\PC WORLD\Desktop\sub1.xlsm")
SourceSht.Copy After:=closedBook.Sheets("rs")
closedBook.Close SaveChanges:=True
Application.ScreenUpdating = True
End Sub

 

[Zot]

magnificent ! thanks so much for your time and patience

Glad could help

 

[abdelfattah]

sorry I come back again but I've found problem and this is my mistake .how can also loop throught in subfolders

if you see this is differnt thread . I will issue a new thread if adjusting is simple , please guide me .

thanks for your help again

 

[Zot]

This will cover a directory ans sub directories. You run just the Sub CopySheetToClosedWB as usual.

Option Compare Text

Sub CopySheetToClosedWB()

LoopAllFolderAndSub ("C:\Users\PC WORLD\Desktop\")

End Sub

Sub LoopAllFolderAndSub(ByVal FPath As String)

Dim FName As String, FullFPath As String, Folds() As String
Dim i As Long, nFold As Long
Dim ws As Worksheet, SourceSht As Worksheet
Dim wb As Workbook, ClosedBook As Workbook

Set ClosedBook = ActiveWorkbook
Set SourceSht = ClosedBook.Sheets("rs")

Application.ScreenUpdating = False

ArryName = Split("sh1,imp,ex,ret", ",")
If Right(FPath, 1) <> "\" Then FPath = FPath & "\"
FName = Dir(FPath & "*.*", vbDirectory)

While Len(FName) <> 0
    If Left(FName, 1) <> "." Then
        FullFPath = FPath & FName
        If (GetAttr(FullFPath) And vbDirectory) = vbDirectory Then
            ReDim Preserve Folds(0 To nFold) As String
            Folds(nFold) = FullFPath
            nFold = nFold + 1
        Else
            If Not FName = ClosedBook.Name Then
                Set wb = Workbooks.Open(FullFPath, UpdateLinks:=False, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
                For Each wsName In ArryName
                    For Each ws In wb.Sheets
                        If wsName = ws.Name Then
                            On Error Resume Next
                            Application.DisplayAlerts = False
                            ClosedBook.Sheets(ws.Name).Delete
                            Err.Clear
                            Application.DisplayAlerts = False
                            On Error GoTo 0
                            Set ws = wb.Sheets(ws.Name)
                            ws.Copy After:=ClosedBook.Sheets("rs")
                        End If
                    Next
                Next
                wb.Close False
            End If
        End If
    End If
    FName = Dir()
Wend

For i = 0 To nFold - 1
    LoopAllFolderAndSub Folds(i)
Next i
ClosedBook.Close True

End Sub

 

[abdelfattah]

very impressive ! thanks again . just I have last thing sometimes I will change sheets names in the files and forgot change the names in the code to be matched so when run the code nothing happens . may be I thought the code doesn't work . so I though if add condition if the sheets names are in the code not matched with the files in directory . then should show pop message with alarming sound " theses sheets are not available , please check agin"

 

[Zot]

Try this

Option Explicit
Option Compare Text

Sub CopySheetToClosedWB()

LoopAllFolderAndSub ("C:\Users\PC WORLD\Desktop\")

End Sub

Sub LoopAllFolderAndSub(ByVal FPath As String)

Dim FName As String, FullFPath As String
Dim Note As String, Folds() As String, ArryName() As String
Dim i As Long, nFold As Long
Dim wsName As Variant
Dim wsNotFound As Boolean
Dim ws As Worksheet, SourceSht As Worksheet
Dim wb As Workbook, ClosedBook As Workbook
Dim dName As Object

Set dName = CreateObject("Scripting.Dictionary")
Set ClosedBook = ActiveWorkbook
Set SourceSht = ClosedBook.Sheets("rs")

Application.ScreenUpdating = False

ArryName = Split("sh1,imp,ex,ret", ",")
If Right(FPath, 1) <> "\" Then FPath = FPath & "\"
FName = Dir(FPath & "*.*", vbDirectory)

While Len(FName) <> 0
    If Left(FName, 1) <> "." Then
        FullFPath = FPath & FName
        If (GetAttr(FullFPath) And vbDirectory) = vbDirectory Then
            ReDim Preserve Folds(0 To nFold) As String
            Folds(nFold) = FullFPath
            nFold = nFold + 1
        Else
            If Not FName = ClosedBook.Name Then
                Set wb = Workbooks.Open(FullFPath, UpdateLinks:=False, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
                Note = ""
                dName.RemoveAll
                For Each wsName In ArryName
                    For Each ws In wb.Sheets
                        If wsName = ws.Name Then
                            dName.Add wsName, Nothing
                            On Error Resume Next
                            Application.DisplayAlerts = False
                            ClosedBook.Sheets(ws.Name).Delete
                            Err.Clear
                            Application.DisplayAlerts = False
                            On Error GoTo 0
                            Set ws = wb.Sheets(ws.Name)
                            ws.Copy After:=ClosedBook.Sheets("rs")
                            Exit For
                        End If
                    Next
                Next
                For Each wsName In ArryName
                    If Not dName.Exists(wsName) Then Note = Note & wsName & ", "
                Next
                    If Len(Note) > 0 Then
                        MsgBox "Missing in " & vbLf & wb.Name & ": " & vbLf & vbLf & Left(Note, Len(Note) - 2)
                    End If
                wb.Close False
            End If
        End If
    End If
    FName = Dir()
Wend

For i = 0 To nFold - 1
    LoopAllFolderAndSub Folds(i)
Next i
ClosedBook.Close True

End Sub

 

[abdelfattah]

thanks again . but the message continue showing even if the sheets are matched . should just show when sheets are unmatched

 

[abdelfattah]

may you fix the problem as in post#26?

 

[Zot]

may you fix the problem as in post#26?

I'm not sure I see that problem. I have created mock up file and slightly change a sheet name in few files. I also have file with all sheets correct + additional file not use. There is no msg pop up on this sheet but pop up sheet with missing sheet name and the msg showed the missing name only.

The msg display the Note string which collect the missing sheet name. Every loop this Note is cleared.

I have no idea at this moment why you see msg in each loop as I'm not seeing it here.