Hello to all!
I'm trying to make a VBA script that allows me to copy the value of certain cells contained in multiple workbooks in a new workbook. This workbooks will be contained all in one folder.
I started from a VBA code used to import and handle multiple csv files in a folder, importing it in a new workbook well formatted.
The code is this:
What I was trying to do is to use the workbook.open as the ActiveSheet.QueryTables.Add in the previous script. The code that I wrote lead excel in an infinite loop, PLEASE DO NOT RUN IT.
This is what I was trying to do (again DO NOT RUN THIS CODE, LEADS TO AN INFINITE LOOP):
I hope I was clear with what I was trying to achieve.
Can somebody help me please?
Do not hesitate to ask clarification please.
I'm trying to make a VBA script that allows me to copy the value of certain cells contained in multiple workbooks in a new workbook. This workbooks will be contained all in one folder.
I started from a VBA code used to import and handle multiple csv files in a folder, importing it in a new workbook well formatted.
The code is this:
VBA Code:
Sub ImportCSVData()
Dim wb As Workbook
Dim wbCSV As Workbook
Dim myPath As String
Dim myFile As Variant
Dim fileType As String
Dim i As Integer
Dim Nsheets As Integer
'Get Target Folder Path From User
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Source Folder"
.AllowMultiSelect = False
.Show
' changed the following line - added the backslash to the path
myPath = .SelectedItems(1) & "\"
End With
'Specify file type
fileType = "*.csv*"
'Target Path with file type
myFile = Dir(myPath & fileType)
'Add Target Workbook
Workbooks.Add 'add new excel file
ActiveWorkbook.SaveAs Filename:= _
myPath & "Total Results.xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False 'save this new excel file as
Set wb = Workbooks.Open(myPath & "Total Results.xlsm") 'open the workbook just created
'Loop through each Excel file in folder
Do While myFile <> ""
Worksheets.Add(Before:=Worksheets("Sheet1")).Name = "measure condition " & i + 1
'changed the following line - from *.csv to myFile ** This was probably what was causing the error
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & myPath & myFile _
, Destination:=ActiveSheet.Range("$A$1"))
.Name = myFile
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
[B16:G143].Select 'number conversion csv values
With Selection
.NumberFormat = "General"
.Value = .Value
End With 'end number conversion csv values
Dim Vin
Dim Vout
Dim Vshu1
Dim Vshu2
Dim Pin
Dim Pout
Vin = Application.WorksheetFunction.Average(Range("B16:B143")) 'make average colums
Vout = Application.WorksheetFunction.Average(Range("C16:C143"))
Vshu1 = Application.WorksheetFunction.Average(Range("D16:D143"))
Vshu2 = Application.WorksheetFunction.Average(Range("E16:E143"))
Pin = Application.WorksheetFunction.Average(Range("F16:F143"))
Pout = Application.WorksheetFunction.Average(Range("G16:G143"))
eff = (Abs(Pout) / Abs(Pin)) * 100
Range("B147").Value = "Vin avg:" ' write results
Range("C147").Value = Abs(Vin)
Range("D147").Value = "V"
Range("B148").Value = "Vout avg:"
Range("C148").Value = Abs(Vout)
Range("D148").Value = "V"
Range("B149").Value = "Vshu1 avg:"
Range("C149").Value = Abs(Vshu1)
Range("D149").Value = "V"
Range("B150").Value = "Vshu2 avg:"
Range("C150").Value = Abs(Vshu2)
Range("D150").Value = "V"
Range("B151").Value = "Pin avg:"
Range("C151").Value = Abs(Pin)
Range("D151").Value = "W"
Range("B152").Value = "Pout avg:"
Range("C152").Value = Abs(Pout)
Range("D152").Value = "W"
Range("B153").Value = "Efficiency:"
Range("C153").Value = eff
Range("D153").Value = "%"
i = i + 1
myFile = Dir
Cells(1, 1).Select 'deselct used values
Loop
'create table of eff points
Nsheets = Workbooks("Total Results.xlsm").Sheets.Count 'number of sheets used
ActiveWorkbook.Sheets(Nsheets).Cells(2, 1).Value = "Pout [w]"
ActiveWorkbook.Sheets(Nsheets).Cells(2, 2).Value = "Eff [%]"
For j = 1 To Nsheets - 1
ActiveWorkbook.Sheets(Nsheets).Cells(3 + j, 1).Value = ActiveWorkbook.Sheets(j).Cells(152, 3) 'take Pout average from the j worksheet
ActiveWorkbook.Sheets(Nsheets).Cells(3 + j, 2).Value = ActiveWorkbook.Sheets(j).Cells(153, 3) 'take eff average from the j worksheet
Next j
'create graph
Sheets(Nsheets).Shapes.AddChart2(-1, xlXYScatterLines).Chart.SetSourceData Source:=Range(Sheets(Nsheets).Cells(3, 1), Sheets(Nsheets).Cells(2 + Nsheets, 2))
Worksheets(Nsheets).ChartObjects(1).Activate
With ActiveChart.Axes(xlCategory) 'x axis name
.HasTitle = True
With .AxisTitle
.Caption = "Output Power [W]"
.Font.Name = "bookman"
.Font.Size = 10
End With
End With
With ActiveChart.Axes(xlValue) 'y axis name
.HasTitle = True
With .AxisTitle
.Caption = "Efficiency [%]"
.Font.Name = "bookman"
.Font.Size = 10
End With
End With
Cells(1, 1).Select 'deselct used values
'Sheets(5).Activate
'Range("A1").Value = Nsheets
'Sheets("measure condition 1").Activate
'ActiveSheet.Cells(144, 2).Select
'ActiveWorkbook.Sheets(2).Cells(1,1).Value = ActiveWorkbook.Sheets(1).Cells(2,2)
'Sheets(Nsheets).Activate
'ActiveSheet.Cells(j + 4, 1).Select
'ActiveCell.Value = j
'ActiveSheet.Cells(j + 4, 2).Select
'ActiveCell.Value = j
'Range(cells(1,1), Cells(2,2)).Select
'Message Box when tasks are completed
MsgBox "Result Import Complete"
End SubWhat I was trying to do is to use the workbook.open as the ActiveSheet.QueryTables.Add in the previous script. The code that I wrote lead excel in an infinite loop, PLEASE DO NOT RUN IT.
This is what I was trying to do (again DO NOT RUN THIS CODE, LEADS TO AN INFINITE LOOP):
VBA Code:
Public Sub open_res()
Dim wbr As Workbook
'Get Target Folder Path From User
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Source Folder"
.AllowMultiSelect = False
.Show
' changed the following line - added the backslash to the path
myPath = .SelectedItems(1) & "\"
End With
'Specify file type
fileType = "*.xlsm*"
'Target Path with file type
myFile = Dir(myPath & fileType)
'Add Target Workbook
Workbooks.Add 'add new excel file
ActiveWorkbook.SaveAs Filename:= _
myPath & "multigraph.xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False 'save this new excel file as
Set wbr = Workbooks.Open(myPath & "multigraph.xlsm") 'open the workbook just created
Do While myFile <> ""
Workbooks.Open myPath & myFile
Loop
End SubI hope I was clear with what I was trying to achieve.
Can somebody help me please?
Do not hesitate to ask clarification please.
