Open a sheet rename and move to another workbook

P

Patrick

Ok,
I have gotten the code below to work BUT it loops on the same file instead
of moving on to the next file. My goal is to open all the files in a
particular directory, renmae the worksheet with the file name and then move
that worksheet to the workbook which the macro is running from i.e. in this
case book2.
Any fix for the incorrect looping?
Only learning here and so need a lot of help
Patrick


Sub AllFolderFiles()
Dim wb As Workbook
Dim TheFile As String
Dim MyPath As String
MyPath = "F:\Work Stuff 2\Work Stuff\Promotion Report"
ChDir MyPath
TheFile = Dir("*.xls")
Do While TheFile <> ""
Set wb = Workbooks.Open(MyPath & "\" & TheFile)
ActiveSheet.Name = ActiveWorkbook.Name
ActiveSheet.Move After:=Workbooks("Book2").Sheets(Sheets.Count)
Loop
End Sub
 
N

NickHK

Patrick,
You need to get the next available file to work on:
Do While TheFile <> ""
Set wb = Workbooks.Open(MyPath & "\" & TheFile)
ActiveSheet.Name = ActiveWorkbook.Name
ActiveSheet.Move After:=Workbooks("Book2").Sheets(Sheets.Count)
TheFile =Dir() '<<<
Loop

Also you have the WB reference so why not use it to make it more clear which
workbook/sheet you are working on.
Also, how do you know what the ActiveSheet of the open workbook is ? It will
depend which was active when the workbook was last closed.
It would better to close the WB if you are finished to avoid having a lot of
open workbooks.

Do While TheFile <> ""
Set WB = Workbooks.Open(MyPath & "\" & TheFile)
With WB.WorkSheets(1)
.Name = WB.Name
.Move After:=Workbooks("Book2").Sheets(Sheets.Count)
End With
WB.Close True/False
TheFile =Dir() '<<<
Loop
 
P

Patrick

The Book2 reference is where the macro is running from and the book I want
the opened sheets to be moved to once they are renamed.
There is only one sheet in each workbook which is being opened and so once
that sheet is moved to the current book2 worksheet the original file would
normally close. I have done this already with a code which specifies file
names and sheet names BUT I now would like if I could make it more wild card
based due to the file names in the folder being changed and this would mean
changing the code each time (which might be every week) and any new files
might also get missed.
Patrick
 
N

NickHK

Patrick,
You are already working on all .xls in that folder.
Or you mean you want to narrow the criteria of workbooks that are opened.
You can use a pattern in the initial Dir call e.g.
TheFile = Dir("Some Pattern*InFileName*.xls")

NickHK
 
P

Patrick

Yes I know, but what is currently happening is that the macro loops on the
first file and keeps reopning it and moving it to the book2 and so it ends
up with endless sheets of the same workboo.
Patrick :)
 
N

NickHK

So you did not add the extra I marked with '<<<<< in my previous post ?
Without that, yes you are going to reopen the same file. With that, you will
work through the files in the folder.

NickHK
 
P

Patrick

What does the '<<<<< stand for?
Patrick


NickHK said:
So you did not add the extra I marked with '<<<<< in my previous post ?
Without that, yes you are going to reopen the same file. With that, you
will
work through the files in the folder.

NickHK
Click to expand...
 
P

Patrick

With my workbook names all being people's names, how can I add a variable at
the end that is going to move it to the next file?
P jave tried <a but obviously my understanding is incorrect as to what can
be selected here?
An example of my file names would be jone.xls , smith.xls, brown.xls etc.
Help !!!
Patrick
 
N

NickHK

Patrick,
You've lost me.
Are you saying that adding the line "TheFile =Dir()" in the loop does NOT
give you the next filename in that folder to open ?

NickHK
 
P

Patrick

Yes, if I just add in "TheFile =Dir()" it gives a request wanting to know
do I want to open the current file again (Book2.xls) and that it will
discard all changes and etc. If I add in a "TheFile = Dir("Some
Pattern*a*.xls")" it then gives the same request, if I add something like
TheFile = Dir("*?*.xls") it also goes back into a loop of opening the first
file multiple times.
Patrick
 
N

NickHK

Partly my fault, should be "TheFile =Dir", no brackets, but I suggest you
read the Help on Dir so you understand how it works.

NickHK
 
P

Patrick

Thanks for all the help. Finally got it working :) , one last question, is
there a way to open the files by their date saved OR how would I use an
array as the list to pull from??
Thanks again for ALL the help
Patrick


I am still confused as to what wildcard would work with my file names. I
have tried *.xls
 
N

NickHK

Patrick,
You can use FileDateTime(MyPath & "\" & TheFile) to get the creation/last
modified date.
- Add the file name and date to a 2-D array.
- Sort by the date.
- Loop through the array opening the filenames.
See below for code

As for opening files from a array:
Dim i as long
For i = LBound(YourArray) to UBound(YourArray)
Set wb = Workbooks.Open(MyPath & "\" & YourArray(i))
....etc
next

Wildcards in the Dir() can be :
<Help>In Microsoft Windows, Dir supports the use of multiple character (*)
and single character (?) wildcards to specify multiple files.</Help>

NickHK

Private Sub CommandButton1_Click()
Dim Folder As String
Dim FileData() As Variant
Dim FileTemp As String
Dim Counter As Long
Dim RetVal As Variant
Dim WB As Workbook

Const RedimBlock As Long = 10
Const DirToSearch As String = "C:\"
Const Pattern As String = "*.xls"
'Create initial elements
ReDim FileData(1 To 2, 1 To RedimBlock)

FileTemp = Dir(DirToSearch & "\" & Pattern)

Do While FileTemp <> ""
'Are all the elements full ?
If Counter = UBound(FileData, 2) Then
'Create another empty block to use
ReDim Preserve FileData(1 To 2, 1 To UBound(FileData, 2) +
RedimBlock)
End If
Counter = Counter + 1
'Store the data
FileData(1, Counter) = FileTemp
FileData(2, Counter) = FileDateTime(DirToSearch & "\" & FileTemp)
'Get the next file
FileTemp = Dir
Loop

'Remove any unused elements from FileData
ReDim Preserve FileData(1 To 2, 1 To Counter)

'Sort the array by the date
RetVal = Sort_TwoDimensionBubble(FileData, 2, 2)

'Now open and process each file
For Counter = LBound(FileData, 2) To UBound(FileData, 2)
Debug.Print FileData(2, Counter), FileData(1, Counter)
'Set WB = Workbooks.Open(FileData(1, Counter))
'process etc
'WB.Close False
Next

End Sub

'Code from http://lsoron.free.fr/cd/vb/sources/biblio/sortbubble.htm
'
' Author:Gordon McI. Fuller
' Copyright:©2000 Force 10 Automation
' Created: Friday, March 17, 2000
'
Function Sort_TwoDimensionBubble(TempArray As Variant, _
Optional iElement As Integer = 1, _
Optional iDimension As Integer = 1, _
Optional bAscOrder As Boolean = True) _
As Boolean
Dim arrTemp As Variant
Dim i As Integer, j As Integer
Dim NoExchanges As Integer

On Error GoTo Error_BubbleSort

If iDimension = 1 Then
ReDim arrTemp(1, UBound(TempArray, 2))
Else
ReDim arrTemp(UBound(TempArray, 1), 1)
End If

'Loop until no more "exchanges" are made.
Do
NoExchanges = True
' Loop through each element in the array
If iDimension = 1 Then
For i = LBound(TempArray, iDimension) To UBound(TempArray,
iDimension) - 1
' If the element is greater than the element
' following it, exchange the two elements.
If (bAscOrder And (TempArray(i, iElement) > TempArray(i + 1,
iElement))) _
Or (Not bAscOrder And (TempArray(i, iElement) < TempArray(i + 1,
iElement))) Then
NoExchanges = False
For j = LBound(TempArray, 2) To UBound(TempArray, 2)
arrTemp(1, j) = TempArray(i, j)
Next j
For j = LBound(TempArray, 2) To UBound(TempArray, 2)
TempArray(i, j) = TempArray(i + 1, j)
Next j
For j = LBound(TempArray, 2) To UBound(TempArray, 2)
TempArray(i + 1, j) = arrTemp(1, j)
Next j
End If
Next i
Else
For i = LBound(TempArray, iDimension) To UBound(TempArray,
iDimension) - 1
' If the element is greater than the element
' following it, exchange the two elements.
If (bAscOrder And (TempArray(iElement, i) > TempArray(iElement,
i + 1))) _
Or (Not bAscOrder And (TempArray(iElement, i) <
TempArray(iElement, i + 1))) Then
NoExchanges = False
For j = LBound(TempArray, 1) To UBound(TempArray, 1)
arrTemp(j, 1) = TempArray(j, i)
Next j
For j = LBound(TempArray, 1) To UBound(TempArray, 1)
TempArray(j, i) = TempArray(j, i + 1)
Next j
For j = LBound(TempArray, 1) To UBound(TempArray, 1)
TempArray(j, i + 1) = arrTemp(j, 1)
Next j
End If
Next i
End If
Loop While Not (NoExchanges)

Sort_TwoDimensionBubble = True
On Error GoTo 0
Exit Function

Error_BubbleSort:
On Error GoTo 0
Sort_TwoDimensionBubble = False

End Function

Patrick said:
Thanks for all the help. Finally got it working :) , one last question, is
there a way to open the files by their date saved OR how would I use an
array as the list to pull from??
Thanks again for ALL the help
Patrick


I am still confused as to what wildcard would work with my file names. I
have tried *.xls
Click to expand...
----------CUT
 
P

Patrick

Ok so I have changed the below code to fit my script but I am getting a
compile error Sub or Function not defined error?
What am I doing wrong here??
Patrick

Private Sub CommandButton1_Click()
Dim Folder As String
Dim FileData() As Variant
Dim FileTemp As String
Dim Counter As Long
Dim RetVal As Variant
Dim WB As Workbook

Const RedimBlock As Long = 20
Const DirToSearch As String = "F:\Promotion Report"
Const Pattern As String = "*.xls"
'Create initial elements
ReDim FileData(1 To 2, 1 To RedimBlock)

FileTemp = Dir(DirToSearch & "\" & Pattern)

Do While FileTemp <> ""
'Are all the elements full ?
If Counter = UBound(FileData, 2) Then
'Create another empty block to use
ReDim Preserve FileData(1 To 2, 1 To UBound(FileData, 2) +
RedimBlock)
End If
Counter = Counter + 1
'Store the data
FileData(1, Counter) = FileTemp
FileData(2, Counter) = FileDateTime(DirToSearch & "\" & FileTemp)
'Get the next file
FileTemp = Dir
Loop

'Remove any unused elements from FileData
ReDim Preserve FileData(1 To 2, 1 To Counter)

'Sort the array by the date
RetVal = Sort_TwoDimensionBubble(FileData, 2, 2)

'Now open and process each file
For Counter = LBound(FileData, 2) To UBound(FileData, 2)
Debug.Print FileData(2, Counter), FileData(1, Counter)
'Set WB = Workbooks.Open(FileData(1, Counter))
'process etc
'WB.Close False
Next

End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Window>Arrange>Tiled - all xls in directory 6
Import Worksheets and "Overright" 9
Index and Match - Errors 6
Do not export buttons to new workbook 2
Little help on Autofill please 4
Global Variables and Constants 17
Save file to Specific Directory - then EMAIL 2
copying worksheets 3

Top