On Thursday, January 10, 2013 4:12:10 PM UTC+5, sandeep chhajer wrote:
>
> 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.
