Renaming Files

[Guest]

Hi...

Can anyone help me out here...initial help has been patchy. I'm beginning to
think this is impossible...

I have 4000 files all randomly saved with random file names, all in
the same folder called AA. The only thing the 4000 files have in common is
that each file contains a sheet called 'summary' and in cell D3 on that sheet
there is a number string sitting amongst random text eg:

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

I need code to open each file, extract the number from cell D3 and then to
rename the file with the extracted number. I need to do this for all files in
the folder. eg:

56673.xls
5566678.xls

Basically I need the code all linked to a macro button that will intiate the
entire process?

Big ask and I'm desperate. Thanks in advance.

Gordonn

 

[Ron de Bruin]

See your other thread

 

[Guest]

Still looking for the start to finish solution. I'm not a pro at this and
fragmnents of code that needs linking together is beyond my expertese...

Thanks anyway.

Gordon.

 

[Ron de Bruin]

Stay in the same thread please

Is there always one number in the value of D3 of each file ?
Answer this and I set up a testing macro for you

 

[Guest]

Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

 

[Ron de Bruin]

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is correct ????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

 

[jseven]

Here's my approach:

This assumes that the random number has the following consistencies: 1.
The first number in the string is the start of your identifying number,
and 2. Your number is followed by a space " ". I've tested this and it
works pretty good. It's a bit slow though. I'll be watching for other
suggestions.
Regards,
Jamie
----------
Sub FileNamer()
Dim FilePath As String
Dim FileName As String
Dim aStart As Integer
Dim DestPath As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'EDIT TO MATCH PATH THAT CONTAINS YOUR FILES
FilePath$ = "C:\Desktop\test\"

'EDIT TO MATCH FOLDER TO HOLD YOUR NEW FILES (MUST BE DIFFERENT FROM
SOURCE DIR
DestPath$ = "C:\Desktop\DestTest\"
If Dir(DestPath$, vbDirectory) = "" Then MkDir (DestPath$)

FileName$ = Dir(FilePath$ & "*.xls")
Do Until FileName$ = ""
Workbooks.Open FilePath$ & FileName$, 0, 1

a$ = Workbooks(FileName$).Sheets("Summary").Range("D3").Value

For x = 1 To Len(a$)
If IsNumeric(Mid(a$, x, 1)) = True Then
aStart = x


a$ = Right(a$, Len(a$) - aStart + 1)
a$ = Trim(Left(a$, InStr(a$, " ")))
GoTo NumFound
End If
Next
NumFound:

ActiveWorkbook.SaveAs DestPath$ & a$ & ".xls"
ActiveWorkbook.Close 0


FileName$ = Dir

Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "done"
End Sub

 

[Ron de Bruin]

Must go now but if the numbers are correct in column C then you can use this macro to
rename the files and move them to C:\ (change that to your folder)

Be sure that the sheet with the filenames and numbers is active

Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
Name cell.Value As "C:\" & cell.Offset(0, 2).Value & ".xls"
Next cell
End Sub


--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is correct ????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

 

[Guest]

Hi Ron...

Yep...just cross referenced 20 entries and all correct. The right number is
falling to the C column.

I take it the second test would be to save the file with the acquired number?

Thanks...this is very impressive stuff.

I await your next post.

Gordon.

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is correct ????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

 

[Guest]

Ron...

how does this code interface with the rest of it?

Thanks

Gordon.

Must go now but if the numbers are correct in column C then you can use this macro to
rename the files and move them to C:\ (change that to your folder)

Be sure that the sheet with the filenames and numbers is active

Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
Name cell.Value As "C:\" & cell.Offset(0, 2).Value & ".xls"
Next cell
End Sub


--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is correct ????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

:

Stay in the same thread please

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

Is there always one number in the value of D3 of each file ?
Answer this and I set up a testing macro for you



--
Regards Ron De Bruin
http://www.rondebruin.nl



Still looking for the start to finish solution. I'm not a pro at this and
fragmnents of code that needs linking together is beyond my expertese...

Thanks anyway.

Gordon.

:

See your other thread

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi...

Can anyone help me out here...initial help has been patchy. I'm beginning to
think this is impossible...

I have 4000 files all randomly saved with random file names, all in
the same folder called AA. The only thing the 4000 files have in common is
that each file contains a sheet called 'summary' and in cell D3 on that sheet
there is a number string sitting amongst random text eg:

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

I need code to open each file, extract the number from cell D3 and then to
rename the file with the extracted number. I need to do this for all files in
the folder. eg:

56673.xls
5566678.xls

Basically I need the code all linked to a macro button that will intiate the
entire process?

Big ask and I'm desperate. Thanks in advance.

Gordonn

 

[Guest]

Hi...

I getting a run time error 1004 saying that the file 'testtest 1.xls' could
not be found on the following line...

Workbooks.Open FilePath$ & FileName$, 0, 1

Any thoughts...

Gordon.

 

[Ron de Bruin]

Hi Gordon

I take it the second test would be to save the file with the acquired number?

Ok, with the sheet with the file names and numbers active run this macro to rename the files
It move the files to "C:\" now but you can change that to a folder like this "C:\Data\"

Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
Name cell.Value As "C:\" & cell.Offset(0, 2).Value & ".xls"
Next cell
End Sub


--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Ron...

Yep...just cross referenced 20 entries and all correct. The right number is
falling to the C column.

I take it the second test would be to save the file with the acquired number?

Thanks...this is very impressive stuff.

I await your next post.

Gordon.

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is correct ????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

:

Stay in the same thread please

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

Is there always one number in the value of D3 of each file ?
Answer this and I set up a testing macro for you



--
Regards Ron De Bruin
http://www.rondebruin.nl



Still looking for the start to finish solution. I'm not a pro at this and
fragmnents of code that needs linking together is beyond my expertese...

Thanks anyway.

Gordon.

:

See your other thread

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi...

Can anyone help me out here...initial help has been patchy. I'm beginning to
think this is impossible...

I have 4000 files all randomly saved with random file names, all in
the same folder called AA. The only thing the 4000 files have in common is
that each file contains a sheet called 'summary' and in cell D3 on that sheet
there is a number string sitting amongst random text eg:

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

I need code to open each file, extract the number from cell D3 and then to
rename the file with the extracted number. I need to do this for all files in
the folder. eg:

56673.xls
5566678.xls

Basically I need the code all linked to a macro button that will intiate the
entire process?

Big ask and I'm desperate. Thanks in advance.

Gordonn

 

[Guest]

Ron...

I get a run time error 53 File not found when I run this macro from a
module. The line below is highlighted in yellow. I placed an empty folder at
c:\data in response to this message but no change. Same error message. I'm
running excel 2003 on windows 2000 of this makes any difference.

Line that highlights in yellow...

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

I sense we are very close here...probably me being dumb.

What next?

Gordon

Hi Gordon

I take it the second test would be to save the file with the acquired number?

Ok, with the sheet with the file names and numbers active run this macro to rename the files
It move the files to "C:\" now but you can change that to a folder like this "C:\Data\"

Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
Name cell.Value As "C:\" & cell.Offset(0, 2).Value & ".xls"
Next cell
End Sub


--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Ron...

Yep...just cross referenced 20 entries and all correct. The right number is
falling to the C column.

I take it the second test would be to save the file with the acquired number?

Thanks...this is very impressive stuff.

I await your next post.

Gordon.

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is correct ????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

:

Stay in the same thread please

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

Is there always one number in the value of D3 of each file ?
Answer this and I set up a testing macro for you



--
Regards Ron De Bruin
http://www.rondebruin.nl



Still looking for the start to finish solution. I'm not a pro at this and
fragmnents of code that needs linking together is beyond my expertese...

Thanks anyway.

Gordon.

:

See your other thread

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi...

Can anyone help me out here...initial help has been patchy. I'm beginning to
think this is impossible...

I have 4000 files all randomly saved with random file names, all in
the same folder called AA. The only thing the 4000 files have in common is
that each file contains a sheet called 'summary' and in cell D3 on that sheet
there is a number string sitting amongst random text eg:

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

I need code to open each file, extract the number from cell D3 and then to
rename the file with the extracted number. I need to do this for all files in
the folder. eg:

56673.xls
5566678.xls

Basically I need the code all linked to a macro button that will intiate the
entire process?

Big ask and I'm desperate. Thanks in advance.

Gordonn

 

[Ron de Bruin]

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

Add the \ after the folder name

"C:\data\"



--
Regards Ron De Bruin
http://www.rondebruin.nl

Ron...

I get a run time error 53 File not found when I run this macro from a
module. The line below is highlighted in yellow. I placed an empty folder at
c:\data in response to this message but no change. Same error message. I'm
running excel 2003 on windows 2000 of this makes any difference.

Line that highlights in yellow...

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

I sense we are very close here...probably me being dumb.

What next?

Gordon

Hi Gordon

I take it the second test would be to save the file with the acquired number?

Ok, with the sheet with the file names and numbers active run this macro to rename the files
It move the files to "C:\" now but you can change that to a folder like this "C:\Data\"

Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
Name cell.Value As "C:\" & cell.Offset(0, 2).Value & ".xls"
Next cell
End Sub


--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Ron...

Yep...just cross referenced 20 entries and all correct. The right number is
falling to the C column.

I take it the second test would be to save the file with the acquired number?

Thanks...this is very impressive stuff.

I await your next post.

Gordon.

:

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is correct
????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

:

Stay in the same thread please

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

Is there always one number in the value of D3 of each file ?
Answer this and I set up a testing macro for you



--
Regards Ron De Bruin
http://www.rondebruin.nl



Still looking for the start to finish solution. I'm not a pro at this and
fragmnents of code that needs linking together is beyond my expertese...

Thanks anyway.

Gordon.

:

See your other thread

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi...

Can anyone help me out here...initial help has been patchy. I'm beginning to
think this is impossible...

I have 4000 files all randomly saved with random file names, all in
the same folder called AA. The only thing the 4000 files have in common is
that each file contains a sheet called 'summary' and in cell D3 on that sheet
there is a number string sitting amongst random text eg:

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

I need code to open each file, extract the number from cell D3 and then to
rename the file with the extracted number. I need to do this for all files in
the folder. eg:

56673.xls
5566678.xls

Basically I need the code all linked to a macro button that will intiate the
entire process?

Big ask and I'm desperate. Thanks in advance.

Gordonn

 

[Guest]

Same error message...line highlighted in Yellow

Name cell.Value As "C:\data\" & cell.Offset(0, 2).Value & ".xls"

Does this work your end?

Gordon

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

Add the \ after the folder name

"C:\data\"



--
Regards Ron De Bruin
http://www.rondebruin.nl

Ron...

I get a run time error 53 File not found when I run this macro from a
module. The line below is highlighted in yellow. I placed an empty folder at
c:\data in response to this message but no change. Same error message. I'm
running excel 2003 on windows 2000 of this makes any difference.

Line that highlights in yellow...

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

I sense we are very close here...probably me being dumb.

What next?

Gordon

Hi Gordon

I take it the second test would be to save the file with the acquired number?

Ok, with the sheet with the file names and numbers active run this macro to rename the files
It move the files to "C:\" now but you can change that to a folder like this "C:\Data\"

Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
Name cell.Value As "C:\" & cell.Offset(0, 2).Value & ".xls"
Next cell
End Sub


--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yep...just cross referenced 20 entries and all correct. The right number is
falling to the C column.

I take it the second test would be to save the file with the acquired number?

Thanks...this is very impressive stuff.

I await your next post.

Gordon.

:

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is correct
????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

:

Stay in the same thread please

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

Is there always one number in the value of D3 of each file ?
Answer this and I set up a testing macro for you



--
Regards Ron De Bruin
http://www.rondebruin.nl



Still looking for the start to finish solution. I'm not a pro at this and
fragmnents of code that needs linking together is beyond my expertese...

Thanks anyway.

Gordon.

:

See your other thread

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi...

Can anyone help me out here...initial help has been patchy. I'm beginning to
think this is impossible...

I have 4000 files all randomly saved with random file names, all in
the same folder called AA. The only thing the 4000 files have in common is
that each file contains a sheet called 'summary' and in cell D3 on that sheet
there is a number string sitting amongst random text eg:

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

I need code to open each file, extract the number from cell D3 and then to
rename the file with the extracted number. I need to do this for all files in
the folder. eg:

56673.xls
5566678.xls

Basically I need the code all linked to a macro button that will intiate the
entire process?

Big ask and I'm desperate. Thanks in advance.

Gordonn

 

[Ron de Bruin]

Hi Gordon

Can you send me the file with the file names/numbers private

--
Regards Ron De Bruin
http://www.rondebruin.nl

Same error message...line highlighted in Yellow

Name cell.Value As "C:\data\" & cell.Offset(0, 2).Value & ".xls"

Does this work your end?

Gordon

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

Add the \ after the folder name

"C:\data\"



--
Regards Ron De Bruin
http://www.rondebruin.nl

Ron...

I get a run time error 53 File not found when I run this macro from a
module. The line below is highlighted in yellow. I placed an empty folder at
c:\data in response to this message but no change. Same error message. I'm
running excel 2003 on windows 2000 of this makes any difference.

Line that highlights in yellow...

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

I sense we are very close here...probably me being dumb.

What next?

Gordon


:

Hi Gordon

I take it the second test would be to save the file with the acquired number?

Ok, with the sheet with the file names and numbers active run this macro to rename the files
It move the files to "C:\" now but you can change that to a folder like this "C:\Data\"

Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
Name cell.Value As "C:\" & cell.Offset(0, 2).Value & ".xls"
Next cell
End Sub


--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yep...just cross referenced 20 entries and all correct. The right number is
falling to the C column.

I take it the second test would be to save the file with the acquired number?

Thanks...this is very impressive stuff.

I await your next post.

Gordon.

:

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is
correct
????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

:

Stay in the same thread please

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

Is there always one number in the value of D3 of each file ?
Answer this and I set up a testing macro for you



--
Regards Ron De Bruin
http://www.rondebruin.nl



Still looking for the start to finish solution. I'm not a pro at this and
fragmnents of code that needs linking together is beyond my expertese...

Thanks anyway.

Gordon.

:

See your other thread

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi...

Can anyone help me out here...initial help has been patchy. I'm beginning to
think this is impossible...

I have 4000 files all randomly saved with random file names, all in
the same folder called AA. The only thing the 4000 files have in common is
that each file contains a sheet called 'summary' and in cell D3 on that sheet
there is a number string sitting amongst random text eg:

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

I need code to open each file, extract the number from cell D3 and then to
rename the file with the extracted number. I need to do this for all files in
the folder. eg:

56673.xls
5566678.xls

Basically I need the code all linked to a macro button that will intiate the
entire process?

Big ask and I'm desperate. Thanks in advance.

Gordonn

 

[Guest]

Hi Gordon

Can you send me the file with the file names/numbers private

--
Regards Ron De Bruin
http://www.rondebruin.nl

Same error message...line highlighted in Yellow

Name cell.Value As "C:\data\" & cell.Offset(0, 2).Value & ".xls"

Does this work your end?

Gordon

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

Add the \ after the folder name

"C:\data\"



--
Regards Ron De Bruin
http://www.rondebruin.nl



Ron...

I get a run time error 53 File not found when I run this macro from a
module. The line below is highlighted in yellow. I placed an empty folder at
c:\data in response to this message but no change. Same error message. I'm
running excel 2003 on windows 2000 of this makes any difference.

Line that highlights in yellow...

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

I sense we are very close here...probably me being dumb.

What next?

Gordon


:

Hi Gordon

I take it the second test would be to save the file with the acquired number?

Ok, with the sheet with the file names and numbers active run this macro to rename the files
It move the files to "C:\" now but you can change that to a folder like this "C:\Data\"

Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
Name cell.Value As "C:\" & cell.Offset(0, 2).Value & ".xls"
Next cell
End Sub


--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yep...just cross referenced 20 entries and all correct. The right number is
falling to the C column.

I take it the second test would be to save the file with the acquired number?

Thanks...this is very impressive stuff.

I await your next post.

Gordon.

:

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is
correct
????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

:

Stay in the same thread please

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

Is there always one number in the value of D3 of each file ?
Answer this and I set up a testing macro for you



--
Regards Ron De Bruin
http://www.rondebruin.nl



Still looking for the start to finish solution. I'm not a pro at this and
fragmnents of code that needs linking together is beyond my expertese...

Thanks anyway.

Gordon.

:

See your other thread

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi...

Can anyone help me out here...initial help has been patchy. I'm beginning to
think this is impossible...

I have 4000 files all randomly saved with random file names, all in
the same folder called AA. The only thing the 4000 files have in common is
that each file contains a sheet called 'summary' and in cell D3 on that sheet
there is a number string sitting amongst random text eg:

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

I need code to open each file, extract the number from cell D3 and then to
rename the file with the extracted number. I need to do this for all files in
the folder. eg:

56673.xls
5566678.xls

Basically I need the code all linked to a macro button that will intiate the
entire process?

Big ask and I'm desperate. Thanks in advance.

Gordonn

 

[Ron de Bruin]

Hi Gordon

The problem is that you have duplicate numbers and files with no number in D3

What do you want to do with these files ?


--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Gordon

Can you send me the file with the file names/numbers private

--
Regards Ron De Bruin
http://www.rondebruin.nl

Same error message...line highlighted in Yellow

Name cell.Value As "C:\data\" & cell.Offset(0, 2).Value & ".xls"

Does this work your end?

Gordon

:

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

Add the \ after the folder name

"C:\data\"



--
Regards Ron De Bruin
http://www.rondebruin.nl



Ron...

I get a run time error 53 File not found when I run this macro from a
module. The line below is highlighted in yellow. I placed an empty folder at
c:\data in response to this message but no change. Same error message. I'm
running excel 2003 on windows 2000 of this makes any difference.

Line that highlights in yellow...

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

I sense we are very close here...probably me being dumb.

What next?

Gordon


:

Hi Gordon

I take it the second test would be to save the file with the acquired number?

Ok, with the sheet with the file names and numbers active run this macro to rename the files
It move the files to "C:\" now but you can change that to a folder like this "C:\Data\"

Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
Name cell.Value As "C:\" & cell.Offset(0, 2).Value & ".xls"
Next cell
End Sub


--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yep...just cross referenced 20 entries and all correct. The right number is
falling to the C column.

I take it the second test would be to save the file with the acquired number?

Thanks...this is very impressive stuff.

I await your next post.

Gordon.

:

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is
correct
????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

:

Stay in the same thread please

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

Is there always one number in the value of D3 of each file ?
Answer this and I set up a testing macro for you



--
Regards Ron De Bruin
http://www.rondebruin.nl



Still looking for the start to finish solution. I'm not a pro at this and
fragmnents of code that needs linking together is beyond my expertese...

Thanks anyway.

Gordon.

:

See your other thread

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi...

Can anyone help me out here...initial help has been patchy. I'm beginning to
think this is impossible...

I have 4000 files all randomly saved with random file names, all in
the same folder called AA. The only thing the 4000 files have in common is
that each file contains a sheet called 'summary' and in cell D3 on that sheet
there is a number string sitting amongst random text eg:

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

I need code to open each file, extract the number from cell D3 and then to
rename the file with the extracted number. I need to do this for all files in
the folder. eg:

56673.xls
5566678.xls

Basically I need the code all linked to a macro button that will intiate the
entire process?

Big ask and I'm desperate. Thanks in advance.

Gordonn

 

[Guest]

Hi Ron...

Duplicate numbers or files without numbers can be deleted if it allows the
wider process to work. If it means after running the big macro that I have to
weed out anomalies then I'm happy to do that before running the second macro.

Is this what you suggest?

Gordon.

Hi Gordon

The problem is that you have duplicate numbers and files with no number in D3

What do you want to do with these files ?


--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Gordon

Can you send me the file with the file names/numbers private

--
Regards Ron De Bruin
http://www.rondebruin.nl



Same error message...line highlighted in Yellow

Name cell.Value As "C:\data\" & cell.Offset(0, 2).Value & ".xls"

Does this work your end?

Gordon

:

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

Add the \ after the folder name

"C:\data\"



--
Regards Ron De Bruin
http://www.rondebruin.nl



Ron...

I get a run time error 53 File not found when I run this macro from a
module. The line below is highlighted in yellow. I placed an empty folder at
c:\data in response to this message but no change. Same error message. I'm
running excel 2003 on windows 2000 of this makes any difference.

Line that highlights in yellow...

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

I sense we are very close here...probably me being dumb.

What next?

Gordon


:

Hi Gordon

I take it the second test would be to save the file with the acquired number?

Ok, with the sheet with the file names and numbers active run this macro to rename the files
It move the files to "C:\" now but you can change that to a folder like this "C:\Data\"

Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
Name cell.Value As "C:\" & cell.Offset(0, 2).Value & ".xls"
Next cell
End Sub


--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yep...just cross referenced 20 entries and all correct. The right number is
falling to the C column.

I take it the second test would be to save the file with the acquired number?

Thanks...this is very impressive stuff.

I await your next post.

Gordon.

:

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is
correct
????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

:

Stay in the same thread please

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

Is there always one number in the value of D3 of each file ?
Answer this and I set up a testing macro for you



--
Regards Ron De Bruin
http://www.rondebruin.nl



Still looking for the start to finish solution. I'm not a pro at this and
fragmnents of code that needs linking together is beyond my expertese...

Thanks anyway.

Gordon.

:

See your other thread

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi...

Can anyone help me out here...initial help has been patchy. I'm beginning to
think this is impossible...

I have 4000 files all randomly saved with random file names, all in
the same folder called AA. The only thing the 4000 files have in common is
that each file contains a sheet called 'summary' and in cell D3 on that sheet
there is a number string sitting amongst random text eg:

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

I need code to open each file, extract the number from cell D3 and then to
rename the file with the extracted number. I need to do this for all files in
the folder. eg:

56673.xls
5566678.xls

Basically I need the code all linked to a macro button that will intiate the
entire process?

Big ask and I'm desperate. Thanks in advance.

Gordonn

 

[Ron de Bruin]

You can't use the same file name for workbooks
Use on error in the code like this

If it can not rename the file it not move it to C:\Data
You can then decide what to do with those files that stay in the folder where you have
select them with GetOpenFilename.


Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
On Error Resume Next
Name cell.Value As "C:\data\" & cell.Offset(0, 2).Value & ".xls"
On Error GoTo 0
Next cell
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl

Hi Ron...

Duplicate numbers or files without numbers can be deleted if it allows the
wider process to work. If it means after running the big macro that I have to
weed out anomalies then I'm happy to do that before running the second macro.

Is this what you suggest?

Gordon.

Hi Gordon

The problem is that you have duplicate numbers and files with no number in D3

What do you want to do with these files ?


--
Regards Ron De Bruin
http://www.rondebruin.nl

On its way to you...

:

Hi Gordon

Can you send me the file with the file names/numbers private

--
Regards Ron De Bruin
http://www.rondebruin.nl



Same error message...line highlighted in Yellow

Name cell.Value As "C:\data\" & cell.Offset(0, 2).Value & ".xls"

Does this work your end?

Gordon

:

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

Add the \ after the folder name

"C:\data\"



--
Regards Ron De Bruin
http://www.rondebruin.nl



Ron...

I get a run time error 53 File not found when I run this macro from a
module. The line below is highlighted in yellow. I placed an empty folder at
c:\data in response to this message but no change. Same error message. I'm
running excel 2003 on windows 2000 of this makes any difference.

Line that highlights in yellow...

Name cell.Value As "C:\data" & cell.Offset(0, 2).Value & ".xls"

I sense we are very close here...probably me being dumb.

What next?

Gordon


:

Hi Gordon

I take it the second test would be to save the file with the acquired number?

Ok, with the sheet with the file names and numbers active run this macro to rename the files
It move the files to "C:\" now but you can change that to a folder like this "C:\Data\"

Sub test()
For Each cell In Columns("A").SpecialCells(xlCellTypeConstants)
Name cell.Value As "C:\" & cell.Offset(0, 2).Value & ".xls"
Next cell
End Sub


--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yep...just cross referenced 20 entries and all correct. The right number is
falling to the C column.

I take it the second test would be to save the file with the acquired number?

Thanks...this is very impressive stuff.

I await your next post.

Gordon.

:

Hi Gordon

First test
Open a new workbook and copy this macro in a normal module
After you run it the file names you have select are in A the value of B is the D3 value and in C the number if it is
correct
????

Do you see the number in C ?


Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "summary" '<---- Change
Set Rng = Range("D3") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 1
RwNum = 0

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = FileNameXls(FNum)

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
SummWks.UsedRange.Value = SummWks.UsedRange.Value

SummWks.UsedRange.Columns("B:B").TextToColumns Destination:=Columns("E:E"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
TrailingMinusNumbers:=True
SummWks.UsedRange.Columns("C").Formula = "=sum(E1:IV1)"

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi Ron...

Yes, there is always a random number (random length) amongst random text in
D3 in all 4000 files.

Thanks for sticking with this.

Gordon.

:

Stay in the same thread please

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

Is there always one number in the value of D3 of each file ?
Answer this and I set up a testing macro for you



--
Regards Ron De Bruin
http://www.rondebruin.nl



Still looking for the start to finish solution. I'm not a pro at this and
fragmnents of code that needs linking together is beyond my expertese...

Thanks anyway.

Gordon.

:

See your other thread

--
Regards Ron De Bruin
http://www.rondebruin.nl



Hi...

Can anyone help me out here...initial help has been patchy. I'm beginning to
think this is impossible...

I have 4000 files all randomly saved with random file names, all in
the same folder called AA. The only thing the 4000 files have in common is
that each file contains a sheet called 'summary' and in cell D3 on that sheet
there is a number string sitting amongst random text eg:

Yellow Diggers 56673 Lincoln
Big Buses London 5566678 London Jan

I need code to open each file, extract the number from cell D3 and then to
rename the file with the extracted number. I need to do this for all files in
the folder. eg:

56673.xls
5566678.xls

Basically I need the code all linked to a macro button that will intiate the
entire process?

Big ask and I'm desperate. Thanks in advance.

Gordonn