Excel - Dynamic Array for data consolidation
Asked By Len
03-Feb-10 03:56 AM
Hi,
After I made use the codes from the same thread, modified for my need
and later I found out that I do not know how to change the codes below
from hard code array to dynamic array to take any number of excel
workbooks ( ie it will increase from time to time ) from a folder and
later to run data consolidation
Sub DataConsol()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Const MAXBOOK As Long = 5
Dim i%, SheetArg$()
Dim sPath1 As String
ReDim SheetArg(1 To MAXBOOK)
Dim sPath As String, sFile As String
Windows("Data Consol.xls").Activate
ThisWorkbook.Worksheets("Sum").Cells.ClearContents
sPath = "C:\Bgt\AF\BA\mic4\"
i = 0
sPath1 = "C:\Bgt\AF\BA\mic4\*.xls"
sFile = Dir(sPath1, vbNormal)
Do While sFile <> ""
i = i + 1
SheetArg(i) = "'" & sPath & "[" & sFile & "]P+L'!R6C2:R47C15 "
sFile = Dir()
Loop
ThisWorkbook.Sheets("Sum").Range("A1").Consolidate _
Sources:=Array(SheetArg), Function:=xlSum, TopRow:=True, _
LeftColumn:=True, CreateLinks:=True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Any helps on the above will be appreciated as I am beginner to excel
vba
Thanks & Regards
Len
Worksheets
(1)
Sheets
(1)
Application.DisplayAlerts
(1)
Cells.ClearContents
(1)
XlCalculationManual
(1)
DataConsol
(1)
VbNormal
(1)
XlSum
(1)
Bob Phillips replied to Len
Sub DataConsol()
Const MAXBOOK As Long = 5
Dim i%, SheetArg$()
Dim sPath1 As String
Dim sPath As String, sFile As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Windows("Data Consol.xls").Activate
ThisWorkbook.Worksheets("Sum").Cells.ClearContents
sPath = "C:\Bgt\AF\BA\mic4\"
i = 0
sPath1 = "C:\Bgt\AF\BA\mic4\*.xls"
sFile = Dir(sPath1, vbNormal)
ReDim SheetArg(1 To 1)
Do While sFile <> ""
i = i + 1
ReDim Preserve SheetArg(1 To i)
SheetArg(i) = "'" & sPath & "[" & sFile & "]P+L'!R6C2:R47C15 "
sFile = Dir()
Loop
ThisWorkbook.Sheets("Sum").Range("A1").Consolidate _
Sources:=Array(SheetArg), Function:=xlSum, TopRow:=True, _
LeftColumn:=True, CreateLinks:=True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
HTH
Bob
Len replied to Bob Phillips
Hi Bob,
Thanks a lot for your response and your codes
Great!...... it works
Regards
Len
code. . . - - HTH. . . Jim Thomlinson Here is the code i am using Select Case Trim(UCase(Worksheets(destSheet).Range("B4"))) Case Is = "JANUARY" Range("AI7") = Worksheets("Year at a Glance").Range("C5") Range("AI8") = Worksheets("Year at a Glance").Range("C6") Range("AI9") = Worksheets("Year at a Glance").Range("C7") Range("AI10 Worksheets("Year at a Glance").Range("C8") Range("AI11") = Worksheets("Year at a Glance").Range("C9") Range("AI12") = Worksheets("Year at a Glance").Range("C10") Range("AI13") = Worksheets("Year at a Glance").Range("C11") Range("AI14") = Worksheets("Year at a Glance").Range("C12
ich für das einlesen der Daten (ist nicht alles drauf): Private Sub UserForm_Initialize() txtPolicendatenGeneralagentur.Text = Worksheets("Antrag").Range("Ao12").Value cmbPolicendatenMitversUVG.Text = Worksheets("Antrag").Range("p14").Value cmbPolicendatenMitversUVGE.Text = Worksheets("Antrag").Range("P19").Value txtPolicendatenGesellschaftUVG.Text = Worksheets("Antrag").Range("ab14").Value txtPolicendatenGesellschaftUVGE.Text = Worksheets("Antrag").Range("ab19").Value cmbAnstragstellerAnrede.Text Worksheets("Antrag").Range("K24").Value txtAntragstellerAndere.Text = Worksheets("Antrag").Range("R24").Value txtAntragstellerNameVorname.Text = Worksheets("Antrag").Range("K27").Value txtAntragstellerGebDat.Text = Worksheets("Antrag").Range("Av27").Value txtAntragstellerStrasse.Text = Worksheets("Antrag
29 / 04 / 2003 par Christophe Application.ScreenUpdating = 3D False ' Unprotect Worksheet ActiveWorkbook.Unprotect Password: = 3D"* ** **" Worksheets("Company Data").Select ' save last changes made at Worksheet "Country Appointments" Worksheets("Country Appointments").Select 'ActiveSheet.Unprotect Password: = 3D"* ** **" Cells.Select Cells.EntireColumn.AutoFit ActiveWorkbook.Save 'TEST CreateBackup = 3D True 'ActiveSheet.Protect Password: = 3D"* ** **", DrawingObjects: = 3DTrue, Contents: = 3DTrue, Scenarios: = 3DTrue 'Delete all Worksheets except 9 of them ActiveWorkbook.Unprotect Password: = 3D"* ** **" Application.DisplayAlerts = 3D False For Each S In ActiveWorkbook.Worksheets If S.Name <> "What is the Scheduler" And S.Name <> S.Name <> "Fax Template" And S.Name <> And S.Name <> "Transitory4" And S.Name <> "Transitory6" Then S.Delete Next S Application.DisplayAlerts = 3D False 'Create Copy content-value of "Country Appointments" moins colonne A into "Transitory1" (no
Excel Data range in Array worksheets Hi, After several attempts to work around but fails to run the complete codes Thus each sheet of every workbook in that J folder for data consolidation purpose : - Sub Totals() Application.DisplayAlerts = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Const MAXBOOK As Long = 4 Dim i%, SheetArg$() Dim sPath1 As String ReDim SheetArg(1 i + 1 SheetArg(i) = "'" & sPath & _ [ & sFile & "]P+L'!R6C2:R47C15 " sFile = Dir() Loop ThisWorkbook.Sheets("Sheet2").Range("A1").Consolidate _ Sources: = Array(SheetArg), Function: = xlSum, TopRow: = True, _ LeftColumn: = True of codes with run time error " Subscript out of range " as indicated below Sub Totals() Application.DisplayAlerts = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Const MAXBOOK As Long = 4 Dim i%, SheetArg$() Dim sPath1 As String ReDim SheetArg(1