Opening and extracting data from another workbook

[OldEngineer]

I would appreciate some advice on my excel VBA code below.
You probably can tell that I am a newbie to VBA in excel... so I am asking the experts.

My code runs ok, but it takes a relatively long time to execute.
It take about 9 seconds to copy over the values in 7 cells from a single other workbook, after entering the letter in the column option dialog box.

My final version will have many more cells, so I am looking for a way to improve execution.
I am sure my work is not very efficient and clearly has some embarrassing brute force elements (like my array of acceptable column letters).
So, please have mercy on an old fart...

Thanks in advance




Option Explicit

Sub OpenAndExtract()

'Declare variables
Dim FileToOpen As String
Dim OpenBook As Workbook
Dim DCol As String
Dim DColLow As String
Dim DCell As String
Dim ColData As Variant

'Set an array of acceptable column letters
ColData = Array("b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", _
"p", "q", "r", "s", "t", "u", "v", "x", "y", "z")

'Disable certain excel features while macro is running
Application.ScreenUpdating = False

'Ask to browse to the desired file to copy data from
FileToOpen = Application.GetOpenFilename(Title:="Browse for the Joint Analysis to Import")

'Check that the path is not empty, exit if empty
If FileToOpen = "" Then
Exit Sub
End If

'Ask for the column letter to which data will be added in the current summary spreadsheet
DCol = InputBox("Enter the Column Letter to Receive Imported Data")

'Create a lower case of the column letter for comparison purposes
DColLow = LCase(DCol)

'Check that the column letter is within acceptable range of columns, if not ask again
If IsInArray(DColLow, ColData) = False Then
MsgBox ("Enter a Column Letter from B to Z")
DCol = InputBox("Enter the Column Letter to Receive Imported Data")
End If

'Check that the column letter is not empty, exit is empty
If DCol = "" Then
Exit Sub
End If

'Open the workbook to copy data from
Set OpenBook = Workbooks.Open(FileToOpen, 0, True)

'Copy Data to This Workbook
DCell = DCol & "6" 'Copy Joint Description
OpenBook.Worksheets("Fastener").Range("B12").Copy
ThisWorkbook.Worksheets("Summary Table").Range(DCell).PasteSpecial xlPasteValues

DCell = DCol & "7" 'Copy Fastener Part Number
OpenBook.Worksheets("Fastener").Range("H11").Copy
ThisWorkbook.Worksheets("Summary Table").Range(DCell).PasteSpecial xlPasteValues

DCell = DCol & "8" 'Copy Fastener Nominal Thread Diameter (in)
OpenBook.Worksheets("Fastener").Range("D16").Copy
ThisWorkbook.Worksheets("Summary Table").Range(DCell).PasteSpecial xlPasteValues

DCell = DCol & "9" 'Copy Fastener Threads per Inch
OpenBook.Worksheets("Fastener").Range("D17").Copy
ThisWorkbook.Worksheets("Summary Table").Range(DCell).PasteSpecial xlPasteValues



DCell = DCol & "23" 'Copy Fastener, Assembly, Worst Msy
OpenBook.Worksheets("Results").Range("D77").Copy
ThisWorkbook.Worksheets("Summary Table").Range(DCell).PasteSpecial xlPasteValues

DCell = DCol & "24" 'Copy Fastener, Assembly, Worst Msu
OpenBook.Worksheets("Results").Range("E77").Copy
ThisWorkbook.Worksheets("Summary Table").Range(DCell).PasteSpecial xlPasteValues

DCell = DCol & "25" 'Copy Fastener, Assembly, Max Stress (ksi)
OpenBook.Worksheets("Results").Range("F77").Copy
ThisWorkbook.Worksheets("Summary Table").Range(DCell).PasteSpecial xlPasteValues

'Close the workbook
OpenBook.Close SaveChanges:=False

End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = UBound(Filter(arr, stringToBeFound)) > -1
End Function

[arnelgp]

some suggestion:


..
..
'Open the workbook to copy data from
Set OpenBook = Workbooks.Open(FileToOpen, 0, True)

With OpenBook.Worksheets("Fastener")
'Copy Data to This Workbook
DCell = DCol & "6" 'Copy Joint Description
ThisWorkbook.Worksheets("Summary Table").Range(DCell) = .Range("B12")

DCell = DCol & "7" 'Copy Fastener Part Number
ThisWorkbook.Worksheets("Summary Table").Range(DCell) = .Range("H11")

DCell = DCol & "8" 'Copy Fastener Nominal Thread Diameter (in)
ThisWorkbook.Worksheets("Summary Table").Range(DCell) = .Range("D16")

DCell = DCol & "9" 'Copy Fastener Threads per Inch
ThisWorkbook.Worksheets("Summary Table").Range(DCell) = .Range("D17")



DCell = DCol & "23" 'Copy Fastener, Assembly, Worst Msy
ThisWorkbook.Worksheets("Summary Table").Range(DCell) = .Range("D77")

DCell = DCol & "24" 'Copy Fastener, Assembly, Worst Msu
ThisWorkbook.Worksheets("Summary Table").Range(DCell) = .Range("E77")

DCell = DCol & "25" 'Copy Fastener, Assembly, Max Stress (ksi)
ThisWorkbook.Worksheets("Summary Table").Range(DCell) = .Range("F77")

End With
'Close the workbook
OpenWorkbook.Close SaveChanges:=False

End Sub

[OldEngineer]

Thank you so much arnelgp.
That change brought the copy time down to a little under 2 seconds.
I really appreciate your input!

[snb]

Sub M_snb()
With Application.FileDialog(3)
If .Show Then
With GetObject(.SelectedItems(1))
With .Sheets(1)
sn = Array(.Cells(12, 2), Cells(11, 8), .Cells(16, 4), .Cells(7, 44), .Cells(77, 4), .Cells(77, 5), .Cells(77, 6))
end with
.Close 0
End With
End If
End With

c00 = Join([transpose(char(65 + row(1:25)))], "")
Do
y = InputBox("column", "Column letter", "A")
Loop Until InStr(c00, y)

ActiveSheet.Cells(6, InStr(c00, y)).Resize(4) = Application.Transpose(Array(sn(0), sn(1), sn(2), sn(3)))
ActiveSheet.Cells(23, InStr(c00, y)).Resize(3) = Application.Transpose(Array(sn(4, sn(5), sn(6))))
End Sub

[OldEngineer]

Thank you snb!
I appreciate your input.
I ran this, but it only accepts column A as an input, which is the one column I need to avoid.
Then it throws an error at the first of the two ActiveSheet.Cells lines.

But I am sure I need to substitute something somewhere.
I will study this to find it's intent and learn from it.
Thanks again!

[snb]

it only accepts column A as an input, which is the one column I need to avoid.
In that case your activeworksheet only contains data in column A.

You might use this instead:


c00 = Join([transpose(char(65 + row(1:25)))], "")

I amended the last 2 lines in my previous post (removed a comma in each line).