OldEngineer
04-17-2024, 02:42 PM
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
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