PDA

View Full Version : [SOLVED] Modify exiting VBA code to open one sheet instead of several multiple sheet copied



r_know
05-26-2010, 11:48 AM
Hi,

Can someone modified below VBA code, to copy only one "particular sheet" instead of copied several multiple sheet from excel files which contained in one folder.

Code presented by malik641


Option Explicit
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszpath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
As Long

Public Type BrowseInfo
hOwner As Long
pIDLRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Function GetDirectory(Optional msg) As String
On Error Resume Next
Dim bInfo As BrowseInfo
Dim path As String
Dim r As Long, x As Long, pos As Integer
'Root folder = Desktop
bInfo.pIDLRoot = 0&
'Title in the dialog
If IsMissing(msg) Then
bInfo.lpszTitle = "Please select the folder of the excel files to copy."
Else
bInfo.lpszTitle = msg
End If
'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 = ""
End If
End Function

Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String
ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
FileName = Dir(path & "\*.xls", vbNormal)
Do Until FileName = ""
If FileName <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
For Each WS In Wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS
Wkb.Close False
End If
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Wkb = Nothing
Set LastCell = Nothing
End Sub


Malik can you help me?

Thanks

Rahul

lucas
05-26-2010, 01:14 PM
You should be able to replace this part of the code:

For Each WS In Wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS

With something along these lines:


With Wkb.Worksheets("sheet1")
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
End with

r_know
05-27-2010, 12:18 AM
Thanks for reply,

But it does not work-out.

Can you check once again what is possibility to make changes?

Attached file is error

lucas
05-27-2010, 10:08 AM
I don't have any way to test this right now as I am at a library but what do you mean by it doesn't work?

do you get an error, if so what is it? Did you change the part that calls sheet 1 and change it to the correct name?

there also seems to be some code missing as after the check:


If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else


There should be an exit sub or something after the then statement because it has checked to see if the sheet is empty.....

r_know
05-28-2010, 11:27 AM
Hi,
Initially I replace as per suggested by you, pls see the picture I got the following error.

With Wkb.Worksheets("sheet1")

Now As per you comments I apply "Correct name of file" but still it gives error.

But I have different Sheets names in excel file folder; I am preferring code should be recognized by the "Sheet1".

Please help me out.

Rahul

rbrhodes
05-28-2010, 12:57 PM
Hi r,

Take out 'WS'




With Wkb.Worksheets("sheet1")
'This line
Set LastCell = .Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
'and this line
.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
End With

r_know
05-29-2010, 12:07 AM
That Cool.
Code works for the Sheet1; thanks a lot.

But I am working in drilling industry; daily Drilling report made by tab name "DDR- 28-05-10". It continuous by daily Tab name change like today DDR 29-05-10.

How do we can fix the problem with "Sheet2" instead of Tab define name in above suggested code.

Here Sheet2 always change daily by tab name.
Pls see the picture.

Rahul

rbrhodes
05-29-2010, 12:46 AM
Hi

Since it's always copying the same sheet? everytime I would suggest using the code name for the sheet which will always be Sheet2 like this:



With Wkb.sheets (2)



From your screen shot it looks like it is (and always will be) Sheet2. I may be wrong...

r_know
05-29-2010, 01:35 AM
Ohh Great,

I tried and it works perfectly.

Thanks A Lot

Special thanks to rbrhodes, lucas and Malik.


Rahul

mdmackillop
05-29-2010, 07:08 AM
Sheets(2) is the displayed tab order and is not the same as code name Sheet2, although it may coincide. The Code Name will not change if the Sheet Name is changed.