I've written the following to extract data from a number of workbooks, opened by a form. It works OK, but the ExtractData sub using arrays to 'copy and paste' the data seems a bit slow (around 2-3 seconds to put the data into a new workbook). Does anyone have any ideas about how to speed it up (screenupdating etc set to false, already)? Thanks for any help.
Code:
Option Explicit
Dim x As Integer
Dim y As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim myLastRow As Long
Const myWBName As String = "Hydrog Reactors*"
Public Sub Main()
Dim myYear As Integer
Dim myarray() As String
Const myPath As String = "blah-de-blah"
Const myFilename As String = "Hydrog Reactors"
Const myExtension As String = ".xls"
Const myPath2 As String = "Spreadsheets"
y = 0
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
myYear = Val(frmMain.cboYear.Text)
For x = 0 To frmMain.lstQtr.ListCount - 1
If frmMain.lstQtr.Selected(x) Then
ReDim Preserve myarray(y)
myarray(y) = frmMain.lstQtr.List(x)
y = y + 1
End If
Next x
For y = 0 To UBound(myarray)
Workbooks.Open myPath & myYear & myPath2 & myarray(y) & " " & myYear & myFilename & " " _
& myarray(y) & " " & myYear & myExtension
Next y
Unload frmMain
Call CheckWorkbooks
Call DeleteRows
Call SetUpPivot
Call CloseWorkbooks
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Public Sub CheckWorkbooks()
ThisWorkbook.Sheets(1).Rows(1).Copy
With Workbooks.Add
.Windows(1).Caption = "Destination"
.Sheets(1).Paste
.Sheets(1).Name = "Summary"
.Sheets(2).Name = "Pivot Table"
.Sheets(3).Delete
End With
For Each wb In Workbooks
If wb.Name Like myWBName Then
wb.Activate
Call CheckWorksheets
End If
Next wb
End Sub
Public Sub CheckWorksheets()
Const mySheetName As String = "Hydrog*"
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like mySheetName Then
ws.Activate
Call ExtractData
End If
Next ws
End Sub
Public Sub ExtractData()
Dim Pos As Variant
Dim OverallArray() As Variant
Dim z As Integer
Set ws = ActiveSheet
Pos = Array(1, 5, 7, 10, 12, 14, 16, 18, 20)
For x = 3 To ws.UsedRange.Rows.Count Step 10
For y = 0 To 8
ReDim Preserve OverallArray(10, z)
OverallArray(y, z) = Cells(x, Pos(y))
If OverallArray(1, z) <> "" Then OverallArray(9, z) = ws.Name
Next y
If Cells(x + 1, 14) <> "" Then
OverallArray(10, z) = "Yes"
OverallArray(5, z) = OverallArray(5, z) + Cells(x + 1, 14)
End If
z = z + 1
Next x
Windows("Destination").Activate
myLastRow = LastRow(Sheet1) + 1
For x = 0 To z - 1
For y = 0 To 10
Cells(myLastRow + x, y + 1) = OverallArray(y, x)
Next y
Next x
End Sub
Public Sub DeleteRows()
Windows("Destination").Activate
For x = LastRow(Sheet1) To 1 Step -1
If WorksheetFunction.CountA(Rows(x)) = 0 Then
Rows(x).EntireRow.Delete
End If
Next x
End Sub
Public Function LastRow(ws As Worksheet) As Long
Set ws = ActiveSheet
If WorksheetFunction.CountA(Cells) > 0 Then
LastRow = ws.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Else:
LastRow = 0
End If
End Function
Public Sub SetUpPivot()
Dim myPivot As PivotTable
myLastRow = LastRow(Sheet1)
Columns("A:K").AutoFit
Range("L2").Select
With Selection
.FormulaR1C1 = "=MAX(RC[-4],RC[-3])"
.AutoFill Destination:=Range("L2:L" & myLastRow)
.AutoFilter
End With
ActiveWorkbook.Names.Add Name:="MyRange", RefersToR1C1:= _
"=Summary!R1C1:R" & myLastRow & "C12"
ActiveSheet.PivotTableWizard SourceType:=xlDatabase, SourceData:="myrange", _
TableDestination:="'Pivot Table'!R3C1", TableName:="mypv1"
Set myPivot = ActiveSheet.PivotTables("mypv1")
myPivot.AddFields RowFields:=Array("Feed", "Data"), ColumnFields:=Array("Date"), _
PageFields:=Array("Reactor")
For x = 1 To 12
Select Case x
Case 6, 12
With myPivot.PivotFields(x)
.Orientation = xlDataField
.Function = xlAverage
.NumberFormat = "0.00"
End With
Case 2, 11
With myPivot.PivotFields(x)
.Orientation = xlDataField
.Position = 1
.Function = xlCount
End With
End Select
Next x
myPivot.PivotSelect "Date[All]", xlLabelOnly
Selection.Group Start:=True, End:=True, Periods:=Array(False, False, False, False, _
True, False, False)
With myPivot.PivotFields("Feed")
.PivotItems("(blank)").Visible = False
End With
End Sub
Public Sub CloseWorkbooks()
For Each wb In Workbooks
If wb.Name Like myWBName Then
wb.Close False
End If
Next wb
End Sub
).
