Quicker way of extracting data?

[Mudface]

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.

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

[Tommy Bak]

Hi

Try replacing

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

with

Windows("Destination").Activate
mylastrow = LastRow(Sheet1) + 1
Range(Cells(mylastrow, 1), Cells(mylastrow + z, 11)) = overallArray

regards Tommy

[Mudface]

Thanks, Tommy, unfortunately, the array comes out 'transposed'. Any ideas? (I'm a bit slow this afternoon ).

[Tommy Bak]

Well, it is friday, so i'm slow to

Range(Cells(mylastrow, 1), Cells(mylastrow + z, 11)) = application.worksheetfunction.transpose(overallArray)

[Mudface]

Brilliant, thanks Tommy, works like a charm with the addition of a z-1. I'll buy you a pint tonight if you can make it to the Tap and Spile in Hull for 8 .