Hi Sandeep.
May be if this code help you.
Public Sub GetRawDataInWorkBook()
Dim objFso As Object: Dim objFolder As
Object
Dim objFile As Object: Dim wbkSrcContact As
Workbook
Dim wbkSrcTarget As Workbook: Dim strFileName As
String
Dim strPath As String: Dim intCount As
Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set objFso = CreateObject("Scripting.FileSystemObject")
strPath = ThisWorkbook.Path
Set objFolder = objFso.GetFolder(strPath)
intCount = 1
For Each objFile In objFolder.Files
Set wbkSrcTarget = Workbooks.Add(1)
wbkSrcTarget.Worksheets(1).Name = "OutPut"
strFileName = objFile.Name
If strFileName = ThisWorkbook.Name Then
GoTo lbl
Else
On Error GoTo lbl
Set wbkSrcContact = Workbooks.Open(ThisWorkbook.Path & "\" &
strFileName)
wbkSrcContact.Worksheets("Sheet2").UsedRange.Copy
wbkSrcTarget.Worksheets("OutPut").Range("A1").PasteSpecial
wbkSrcTarget.SaveAs ThisWorkbook.Path & "\Test\" &
wbkSrcTarget.Name & intCount & ".xlsx", 51
wbkSrcTarget.Close
wbkSrcContact.Close
Set wbkSrcTarget = Nothing
Set wbkSrcContact = Nothing
intCount = intCount + 1
End If
lbl:
If Err.Number <> 0 Then
wbkSrcTarget.Close
Set wbkSrcTarget = Nothing
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Note: This code select all files in the folder where this file has placed
and copy the 2nd sheets of each file in the folder named test in the which
is also placed in the same folder where this file has placed
regards
prince
On Thursday, January 10, 2013 4:42:10 PM UTC+5:30, 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.
