Copy a Specific Worksheet to a new Workbook using VBA

[syednizamudeen]

[FONT=&quot]Hi all,
[/FONT]
[FONT=&quot]
[/FONT]
[FONT=&quot]I have a folder which contains like a 100 .xlsx files. I want a Macro which uses the Folder Picker to input the source folder. then, the macro should look for each workbook in the folder and and look for every worksheet in the workbook for C15="5/7/2016".

If a specific worksheet has the value in the cell C15="5/7/2016", it has to be copied to a new workbook.
[/FONT]
[FONT=&quot]
[/FONT]
[FONT=&quot]My code goes like this

[/FONT]
[FONT=&quot] [/FONT][FONT=&quot]Sub WksToWbk()
Dim strFolder As String
Dim strFile As String
Dim wbk As Workbook
Dim wks As Worksheet
Dim cnt As Long
'Prompt user to select folder
With Application.FileDialog(4) ' msoFileDialogFolderPicker
If .Show Then
strFolder = .SelectedItems(1)
Else
MsgBox "No folder selected!", vbExclamation
Exit Sub
End If
End With
' Make sure folder path ends in \
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
On Error GoTo ErrHandler
' Reduce screen flicker
Application.ScreenUpdating = False
' Get first filename
strFile = Dir(strFolder & "*.xlsx")
' Loop through files
Do While strFile <> ""
' Open workbook
Set wbk = Workbooks.Open(Filename:=strFolder & strFile)
For Each wks In ActiveWorkbook.Worksheets
If wks.Range("C15").Value = "5/7/2016" Then
wks.Copy
With ActiveWorkbook
.SaveAs Filename:="C:\Users\Meera\Documents\Copy Ws to new Wbook Macro" _
& "\File" & cnt & ".xlsx"
.Close
End With
cnt = cnt + 1
End If
Next wks
Loop
MsgBox ("Created" & cnt & " Excel Files")
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

[/FONT]
[FONT=&quot]Present code does not close the workbook and and look for the next workbook...there is some problem with the files and worksheet looping...Please help me to correct the above code.
[/FONT]
[FONT=&quot]


[/FONT]

 

[Norie]

Try this.

Sub WksToWbk()
Dim strFolder As String
Dim strFile As String
Dim wbk As Workbook
Dim wks As Worksheet
Dim cnt As Long

    'Prompt user to select folder
    With Application.FileDialog(4)    ' msoFileDialogFolderPicker
        If .Show Then
            strFolder = .SelectedItems(1)
        Else
            MsgBox "No folder selected!", vbExclamation
            Exit Sub
        End If
    End With
    
    ' Make sure folder path ends in \
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If
    
    On Error GoTo ErrHandler
    ' Reduce screen flicker
    Application.ScreenUpdating = False
    ' Get first filename
    strFile = Dir(strFolder & "*.xlsx")
    ' Loop through files
    Do While strFile <> ""
    ' Open workbook
        Set wbk = Workbooks.Open(Filename:=strFolder & strFile)
        
        For Each wks In ActiveWorkbook.Worksheets
            If wks.Range("C15").Value = "5/7/2016" Then
                wks.Copy
                With ActiveWorkbook
                    .SaveAs Filename:="C:\Users\Meera\Documents\Copy Ws to new Wbook Macro" _
                                      & "\File" & cnt & ".xlsx"
                    .Close
                End With
                cnt = cnt + 1
            End If
        Next
        
        wbk.Close SaveChanges:=False

        strFile = Dir()
    Loop
    
    MsgBox ("Created" & cnt & " Excel Files")
    
ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
    
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
    
End Sub

 

[syednizamudeen]

wbk.Close SaveChanges:=False

strFile = Dir()

The magic lines...Thank you so much...it works..