Excel Data Combine

  • Thread starter mrc1986 via OfficeKB.com
  • Start date
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
 
N

NickHK

Are all the data in the source worksheets in a regular table format ?
If so, you can just query each with SQL :
SELECT SUM(ColumnE) FROM WorkSheetsName

If it fails because that worksheet is not present, you can trap the error.

Look into using ADO with Excel or many using a QueryTable in a loop.

NickHK

mrc1986 via OfficeKB.com said:
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
 
T

Tom Ogilvy

You can get the sum of the values in a column directly from the sheet without
building any formulas or transporting data or later deleting anything with
something similar to

dblSum = Application.Sum(Workbooks(JustFileName).Worksheets(1).Columns(3))

then write the sum in the appropriate summary cell.

--
Regards,
Tom Ogilvy


mrc1986 via OfficeKB.com said:
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
 

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

Top