M
mrc1986 via OfficeKB.com
What i have is about 3000 worksheets that I need to sum the Column E in and
put it in one workbook. I have something that almost works. It takes the
selected files and puts the information in columns sums then deletes
everything but the file name and the summed total. Here is the kicker i just
found out that the files that i need to pull the data from have over the 8000
rows of data in column E, that does not work because excel will only allow
256 columns. I am really new to Vb and I need some help.
This is the code that i am using, it is something that i found in another
post.
Sub Combine()
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 = "Sheet1" '<---- Change
Set Rng = Range("E:E")
'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 2
RwNum = 1
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 = JustFileName
'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
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
Range("IV2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-254]:RC[-1])"
Range("IV2").Select
Selection.AutoFill Destination:=Range("IV2:IV1000"), Type:=xlFillDefault
Range("IV2:IV1000").Select
ActiveWindow.SmallScroll Down:=-402
Selection.Copy
Columns("B:B").Select
Selection.ColumnWidth = 4.43
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("C2:IV1000").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("A1").Select
' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
MsgBox "The Summary is ready, save the file if you want to keep it"
End With
End If
End Sub
Thank you for you time
Mark
put it in one workbook. I have something that almost works. It takes the
selected files and puts the information in columns sums then deletes
everything but the file name and the summed total. Here is the kicker i just
found out that the files that i need to pull the data from have over the 8000
rows of data in column E, that does not work because excel will only allow
256 columns. I am really new to Vb and I need some help.
This is the code that i am using, it is something that i found in another
post.
Sub Combine()
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 = "Sheet1" '<---- Change
Set Rng = Range("E:E")
'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 2
RwNum = 1
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 = JustFileName
'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
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
Range("IV2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-254]:RC[-1])"
Range("IV2").Select
Selection.AutoFill Destination:=Range("IV2:IV1000"), Type:=xlFillDefault
Range("IV2:IV1000").Select
ActiveWindow.SmallScroll Down:=-402
Selection.Copy
Columns("B:B").Select
Selection.ColumnWidth = 4.43
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("C2:IV1000").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("A1").Select
' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
MsgBox "The Summary is ready, save the file if you want to keep it"
End With
End If
End Sub
Thank you for you time
Mark