Dear excel guru,
I want to copy only the 2nd sheet of the all workbooks from a particular
folder. Please accordingly rectify the below mentioned code which I also got
this forum.
Option Explicit
'32-bit API declarations
DeclareFunction SHGetPathFromIDList Lib "shell32.dll" _Alias
"SHGetPathFromIDListA" (ByVal pidl AsLong, ByVal _pszpath AsString) AsLong
DeclareFunction SHBrowseForFolder Lib "shell32.dll" _Alias "SHBrowseForFolderA"
(lpBrowseInfo AsBrowseInfo) _AsLong
Public Type BrowseInfo hOwner AsLong pIDLRoot AsLong pszDisplayName
AsString lpszTitle AsString ulFlags AsLong lpfn AsLong lParam
AsLong iImage AsLongEnd Type
FunctionGetDirectory(Optional msg) AsStringOn Error Resume Next
Dim bInfo As BrowseInfoDim path AsStringDim r AsLong, x AsLong, pos AsInteger
'Root folder = Desktop
bInfo.pIDLRoot = 0&
'Title in the dialog
IfIsMissing(msg) Then bInfo.lpszTitle = "Please select the folder of the
excel files to copy."
Else
bInfo.lpszTitle = msg
EndIf
'Type of directory to return
bInfo.ulFlags = &H1
'Display the dialog
x = SHBrowseForFolder(bInfo)
'Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)If r Then pos =
InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
EndIf
End Function
SubCombineFiles()Dim path AsStringDimFileName
AsStringDimLastCell As RangeDim Wkb As WorkbookDim WS
As WorksheetDimThisWB AsString
ThisWB = ThisWorkbook.Name
Application.EnableEvents = False Application.ScreenUpdating = False
path = GetDirectory
FileName = Dir(path & "\*.xls", vbNormal)
Do UntilFileName = ""If FileName <> ThisWB ThenSet Wkb =
Workbooks.Open(FileName:=path & "\" & FileName)For Each WS InWkb.WorksheetsSet
LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
IfLastCell.Value = "" And LastCell.Address = Range("$A$1").Address ThenElse
WS.Copy
After:=ThisWorkbook.Sheetst(ThisWorkbook.Sheets.Count)
EndIf
Next WS Wkb.Close FalseEndIf
FileName = Dir()
Loop
Application.EnableEvents = True Application.ScreenUpdating = True
Set Wkb = NothingSet LastCell = NothingEnd Sub
Sent on my BlackBerry® from Vodafone
--
Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To post to this group, send email to excel-macros@googlegroups.com.
To unsubscribe from this group, send email to
excel-macros+unsubscr...@googlegroups.com.
Visit this group at http://groups.google.com/group/excel-macros?hl=en.
