This is my current VBA code:
Option Explicit
Private Function LoopThroughFolder(RootFolder As String, CsvFolder As String, Status As String)
Dim folder, StrFile As String
Dim wks As Worksheet
folder = RootFolder & "\" & CsvFolder & "\" & Status
StrFile = Dir(folder & "\*.csv")
Do While Len(StrFile) > 0
Set wks = Worksheets(CsvFolder & Status)
ImportCsv folder & "\" & StrFile, wks
StrFile = Dir
Loop
'Debug.Print RootFolder & "\" & CsvFolder & "\" & Status & " >>> OK!"
End Function
Private Function ImportCsv(CsvFile As String, wks As Worksheet)
Dim row&, col As Integer
'Debug.Print CsvFile
row = wks.Cells(Rows.Count, 1).End(xlUp).row
With wks.QueryTables _
.Add(Connection:="TEXT;" & CsvFile, Destination:=wks.Cells(row + 1, 1))
.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)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Function
Public Sub ImportFolderCsv()
Dim RootFolder As String
RootFolder = "C:\Users\chinkai\Desktop\dims investigate"
Dim CsvFolders(1 To 2) As String
CsvFolders(1) = "csvVeh"
CsvFolders(2) = "csvCust"
Dim Statuses(1 To 2) As String
Statuses(1) = "FAIL"
Statuses(2) = "PASS"
Dim i, j As Integer
Dim folder As String
Dim ws As Worksheet
For i = 1 To 1
For j = 1 To 2
Sheets.Add.Name = CsvFolders(i) & Statuses(j)
LoopThroughFolder RootFolder, CsvFolders(i), Statuses(j)
Next j
Next i
End Sub
When I open my worksheets to view, the data appears in the form of an inverted triangle. Data from the first CSV goes into the top right corner, data from the second CSV goes below but to the left, so on and so forth, until the last CSV where data appears in the bottom left corner.
What my data looks like:
New to Excel VBA, so most of the code here are copy-pasta. I tried to tweak what I can but now I am not sure where I have gone wrong. Advice/feedback appreciated, thank you!
Edit: made some changes as suggested. Updated my code above and also provided a screen capture of this weird display...
I have played a bit with your code, but I could not replicate the "reversed triangle thing". However, just to make you started somewhere:
Replace the ActiveSheet with a reference of the worksheet, that you should pass as a parameter to the ImportCsv function:
Private Function ImportCsv(CsvFile As String, wks As Worksheet)
Dim row&, col As Long
Debug.Print CsvFile
row = wks.Cells(Rows.Count, 1).End(xlUp).row
With wks.QueryTables _
.Add(Connection:="TEXT;" & CsvFile, Destination:=wks.Cells(row + 1, 1))
And you take the wks like this from the Status string:
Private Function LoopThroughFolder(RootFolder As String, CsvFolder As String, Status As String)
Dim folder, StrFile As String
Dim wks As Worksheet
folder = RootFolder & "\" & CsvFolder & "\" & Status
StrFile = Dir(folder & "\*.csv")
Do While Len(StrFile) > 0
Set wks = Worksheets("csvVeh" & Status)
Two more important points:
write Option Explicit on the top of your module and try to declare all variables. Then go to Debug>Compile on the VBEditor ribbon and declare what is not declared.
as #Peh mentioned in the comments if you declare like this in C++ Dim a, b as Integer, then a and b are Integers. In VBA only b is declared as an Integer, a is a Variant. You should declare Dim a As Integer, b as Integer
Why Use Integer Instead of Long?
I'm trying to import a lot of text files with numerical names into a separate worksheets.
The loop to create the worksheets works fine
Dim i as integer 'initial file name
Dim k as integer 'final file name
i = Cells(3, 3).Value
k = Cells(5, 3).Value
Do while i <= k
Worksheets.Add.Name = i
i = i +5
Loop
and for importing specific individual files, this line also seems to work fine (when including the .FileNames .RowNumbers. RefreshPeriod etc. commands):
With Activesheet.QueryTables.Add(Connection:="TEXT;C:\temp\load_excel\15.txt" _, Destination:=Range ("$A$1"))
I would like to replace the "TEXT;C:\temp\load_excel\15.txt" with something more that allows me to use two different variables to change the files being imported:
Dim Folder As String
Dim File As String
Dim DQ as String
DQ = """" 'double quotation marks
Folder = Cells(14, 2).Value 'cell which states C:\temp\load_excel\
File = DQ & "TEXT;" & Folder & i & ".txt" & DQ
'for i = 15 this gives "TEXT;C:\temp\load_excel\15.txt"
Is there a way to incorporate the two so I can have a loop like this?
Do while i <=k
Worksheets.Add.Name = i
Activesheet.QueryTables.Add(Connection:= File _, Destination:=Range ("$A$1"))
i = i +5
Loop
As far as I can see, this should work, but when I try and run it I get a Run-time error '1004': Application or object-defined error. If anyone could help, it would be greatly appreciated.
EDIT: here is exact code being used
Sub ImportPLEtextFiles()
Dim i As Integer ''initial file name
Dim k As Integer ''final file name
Dim DQ As String '' Double quotation marks
Dim Folder As String
Dim File As String
i = Cells(3, 3).Value
k = Cells(5, 3).Value
DQ = """"
Folder = Cells(14, 2).Value
File = DQ & Folder & i & ".txt" & DQ
Do While i <= k
Worksheets.Add.Name = i
File = DQ & "TEXT;" & Folder & i & ".txt" & DQ
With ActiveSheet.QueryTables.Add(Connection:=File _
, Destination:=Range("$A$1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
i = i + 5
Loop
End Sub
Put this inside your loop.
File = "TEXT;" & Cells(14, 2).Value & i & ".txt"
With Sheets(i).QueryTables.Add(Connection:= _
File, Destination:=Range("$A$1"))
.Refresh BackgroundQuery:=False
End With
I use this code to retrieve historical stock prices for about 40 tickers. I found it here http://www.mathfinance.cn/download-multiple-stock-quotes-from-yahoo-finance
It downloads about half of the symbols before a Run-time Error '1004' pops up. "Unable to open http://table.finance.yahoo.com/table.csv?s=Tickersymbol&a=11&b=21&c=1998 The internet site reports that the item you requested cannot be found (HTTP/1.0 404)
Can I change the code so this error won't happen? The code is below
Sub Get_Yahoo_finance()
Dim Sh As Worksheet
Dim Rng As Range
Dim Cell As Range
Dim Ticker As String
Dim StartDate As Date
Dim EndDate As Date
Dim a, b, c, d, e, f
Dim StrURL As String
Set Sh = Worksheets("Input")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
For Each Cell In Rng
Ticker = Cell.Value
StartDate = Cell.Offset(0, 1).Value
EndDate = Cell.Offset(0, 2).Value
a = Format(Month(StartDate) - 1, "00") ' Month minus 1
b = Day(StartDate)
c = Year(StartDate)
d = Format(Month(EndDate) - 1, "00")
e = Day(EndDate)
f = Year(EndDate)
StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
If WorksheetExists(Ticker, ActiveWorkbook) Then
Application.DisplayAlerts = False
Sheets(Ticker).Select
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.Worksheets.Add.Name = Ticker
Else
ActiveWorkbook.Worksheets.Add.Name = Ticker
End If
With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=Range("A1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.Refresh BackgroundQuery:=False
End With
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1))
Range("A2").Select
Range(Selection, Selection.End(xlDown)).NumberFormat = "d-mmm-yy"
Columns("A:F").EntireColumn.AutoFit
Next Cell
End Sub
Function WorksheetExists(SheetName As String, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function
EDIT: The code below fixes the issue you reported but runs out of memory very quickly. I have created another answer which I think is much better and robust
It looks like your query is not recognised by the server. You can add some error checks to continue if such an error is encountered.
Sub Get_Yahoo_finance()
Dim Sh As Worksheet
Dim Rng As Range
Dim Cell As Range
Dim Ticker As String
Dim StartDate As Date
Dim EndDate As Date
Dim a, b, c, d, e, f
Dim StrURL As String
Dim errorMsg As String
Set Sh = Worksheets("Input")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
For Each Cell In Rng
Ticker = Cell.Value
StartDate = Cell.Offset(0, 1).Value
EndDate = Cell.Offset(0, 2).Value
a = Format(Month(StartDate) - 1, "00") ' Month minus 1
b = Day(StartDate)
c = Year(StartDate)
d = Format(Month(EndDate) - 1, "00")
e = Day(EndDate)
f = Year(EndDate)
StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
If WorksheetExists(Ticker, ActiveWorkbook) Then
Application.DisplayAlerts = False
Sheets(Ticker).Select
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.Worksheets.Add.Name = Ticker
Else
ActiveWorkbook.Worksheets.Add.Name = Ticker
End If
With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=Range("A1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
On Error Resume Next
.Refresh BackgroundQuery:=False
errorMsg = IIf(Err.Number = 0, "", Err.Description)
On Error GoTo 0
End With
If errorMsg = "" Then
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1))
Range("A2").Select
Range(Selection, Selection.End(xlDown)).NumberFormat = "d-mmm-yy"
Columns("A:F").EntireColumn.AutoFit
Else
Range("A1") = errorMsg
End If
Next Cell
End Sub
Function WorksheetExists(SheetName As String, Optional WhichBook As Workbook) As Boolean '
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function
You might want to delete the sheet instead of putting an error message in it or maybe send a MsgBox instead...
I can't get your method to work properly (I get out of memory errors after a few 100s of tickers).
So I got interested and dug a bit further. I propose another approach below which is more complex but yields better results (I uploaded the 500 stocks of the S&P in 3 minutes (about 3 seconds for the actual job in Excel, the rest is connection / download time). Just copy paste the whole code in a module and run the runBatch procedure.
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMillisecond As Long)
Private Declare Function URLDownloadToCacheFile Lib "urlmon" _
Alias "URLDownloadToCacheFileA" (ByVal lpUnkcaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwBufLength As Long, ByVal dwReserved As Long, _
ByVal IBindStatusCallback As Long) As Long
Public Sub runBatch()
'Assumes there is a sheet called "Input" with 3 columns:
'Ticker, Start Date, End Date
'Actual data starts from Row 2
Dim tickerData As Variant
Dim ticker As String
Dim url As String
Dim i As Long
Dim yahooData As Variant
On Error GoTo error_handler
Application.ScreenUpdating = False
tickerData = Sheets("Input").UsedRange
For i = LBound(tickerData, 1) + 1 To UBound(tickerData, 1) 'skip first row
ticker = tickerData(i, 1)
url = getYahooUrl(ticker, tickerData(i, 2), tickerData(i, 3))
yahooData = getCsvContent(url)
If isArrayEmpty(yahooData) Then
MsgBox "No data found for " + ticker
Else
copyDataToSheet yahooData, ticker
End If
Next i
Application.ScreenUpdating = True
Exit Sub
error_handler:
MsgBox "Error found while reading ticker [" + ticker + "]: " + Err.Description
Application.ScreenUpdating = True
End Sub
Private Function getYahooUrl(ByVal ticker As String, ByVal startDate As Date, ByVal endDate As Date) As String
Dim a As String
Dim b As String
Dim c As String
Dim d As String
Dim e As String
Dim f As String
a = Format(Month(startDate) - 1, "00") ' Month minus 1
b = Day(startDate)
c = Year(startDate)
d = Format(Month(endDate) - 1, "00")
e = Day(endDate)
f = Year(endDate)
getYahooUrl = "http://table.finance.yahoo.com/table.csv?" & _
"s=" & ticker & "&" & _
"a=" & a & "&" & _
"b=" & b & "&" & _
"c=" & c & "&" & _
"d=" & d & "&" & _
"e=" & e & "&" & _
"f=" & f & "&" & _
"g=d&ignore=.csv"
End Function
Private Function getCsvContent(url As String) As Variant
Const RETRY_NUMS As Long = 3 'How m any times do we retry the download before giving up
Dim szFileName As String
Dim i As Long
For i = 1 To RETRY_NUMS
szFileName = Space$(300)
If URLDownloadToCacheFile(0, url, szFileName, Len(szFileName), 0, 0) = 0 Then
getCsvContent = getDataFromFile(Trim(szFileName), ",")
Kill Trim(szFileName) 'to make sure data is refreshed next time
Exit Function
End If
Sleep (500)
Next i
End Function
Private Sub copyDataToSheet(data As Variant, sheetName As String)
If Not WorksheetExists(sheetName) Then
Worksheets.Add.Name = sheetName
End If
With Sheets(sheetName)
.Cells.ClearContents
.Cells(1, 1).Resize(UBound(data, 1), UBound(data, 2)) = data
.Columns(1).NumberFormat = "d-mmm-yy"
.Columns("A:F").AutoFit
End With
End Sub
Private Function WorksheetExists(sheetName As String, Optional WhichBook As Workbook) As Boolean '
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(sheetName).Name) > 0)
End Function
Private Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
End Function
Private Function getDataFromFile(parFileName As String, parDelimiter As String, Optional parExcludeCharacter As String = "") As Variant 'V.20081021
'parFileName is supposed to be a delimited file (csv...)
'Returns an empty array if file is empty or can't be opened
'20081021: number of columns based on the line with the largest number of columns, not on the first line
' parExcludeCharacter: sometimes csv files have quotes around strings: "XXX" - if parExcludeCharacter = """" then removes the quotes
'20081022: Error Checks in place
Dim locLinesList() As Variant
Dim locData As Variant
Dim i As Long
Dim j As Long
Dim locNumRows As Long
Dim locNumCols As Long
Dim fso As Variant
Dim ts As Variant
Const REDIM_STEP = 10000
Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo error_open_file
Set ts = fso.OpenTextFile(parFileName)
On Error GoTo unhandled_error
'Counts the number of lines and the largest number of columns
ReDim locLinesList(1 To 1) As Variant
i = 0
Do While Not ts.AtEndOfStream
If i Mod REDIM_STEP = 0 Then
ReDim Preserve locLinesList(1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant
End If
locLinesList(i + 1) = Split(ts.ReadLine, parDelimiter)
j = UBound(locLinesList(i + 1), 1) 'number of columns
If locNumCols < j Then locNumCols = j
i = i + 1
Loop
ts.Close
locNumRows = i
If locNumRows = 0 Then Exit Function 'Empty file
ReDim locData(1 To locNumRows, 1 To locNumCols + 1) As Variant
'Copies the file into an array
If parExcludeCharacter <> "" Then
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
If Left(locLinesList(i)(j), 1) = parExcludeCharacter Then
If Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = Mid(locLinesList(i)(j), 2, Len(locLinesList(i)(j)) - 2) 'If locTempArray = "", Mid returns ""
Else
locLinesList(i)(j) = Right(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
ElseIf Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = Left(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
Else
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
End If
getDataFromFile = locData
Exit Function
error_open_file: 'returns empty variant
unhandled_error: 'returns empty variant
End Function
I ran it once and it failed. Put a breakpoint on the query line, loaded the yahoo address into my browser to make sure it was valid, then the script worked. I also made sure that there were no other worksheets in the project. Here's a screenshot of the VBA editor and where the breakpoint goes:
You can stick the variable into a watch window and then fool around with it to see what it does. If you come up with any applications for this I'd love to hear about them!
Attached is a "simpler" solution using the original code modified to retry retrieving the ticker data upto 3 times (waiting a few seconds between attempts) before finally admitting failure by messagebox. My 2 cents :-)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMillisecond As Long)
Sub Get_Yahoo_finance_history()
Dim Sh As Worksheet
Dim Rng As Range
Dim Cell As Range
Dim Ticker As String
Dim StartDate As Date
Dim EndDate As Date
Dim a, b, c, d, e, f
Dim StrURL As String
Dim RetryCount As Integer
'turn calculation off
'Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Set Sh = Worksheets("Input")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
For Each Cell In Rng
Ticker = Cell.Value
StartDate = Cell.Offset(0, 1).Value
EndDate = Cell.Offset(0, 2).Value
a = Format(Month(StartDate) - 1, "00") ' Month minus 1
b = Day(StartDate)
c = Year(StartDate)
d = Format(Month(EndDate) - 1, "00")
e = Day(EndDate)
f = Year(EndDate)
StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
If WorksheetExists(Ticker, ActiveWorkbook) Then
Sheets(Ticker).Select
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.Worksheets.Add.Name = Ticker
Else
ActiveWorkbook.Worksheets.Add.Name = Ticker
End If
RetryCount = 0 Retry:
If RetryCount > 3 Then
Range("A1") = errorMsg
MsgBox "After 3 attempts: Could not retrieve data for " + Ticker
End
End If
RetryCount = RetryCount + 1
With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=Range("A1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
On Error Resume Next
.Refresh BackgroundQuery:=False
errorMsg = IIf(Err.Number = 0, "", Err.Description)
On Error GoTo 0
End With
If errorMsg = "" Then
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1))
Columns("A").EntireColumn.NumberFormat = "mm/dd/yyyy"
Columns("B:E").EntireColumn.NumberFormat = "$###,##0.00"
Columns("F").EntireColumn.NumberFormat = "###,##0"
Columns("B:E").EntireColumn.NumberFormat = "$###,##0.00"
Columns("A:F").EntireColumn.AutoFit
Else
Sleep (500)
Sheets(Ticker).Cells.ClearContents
GoTo Retry
End If
Next Cell
'turn calculation back on
'Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function WorksheetExists(SheetName As String, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function
This is the code i use to create a graph which searches for .csv {created using excel application} file in the path specified. It plots the column 'B' { Y axis } against column 'C' {X-axis}.. I want to one more column 'A' to my Y axis keeping column 'C' as the X axis.. How can i do that???
here is the code...
Sub Draw_Graph()
Dim strPath As String
Dim strFile As String
Dim strChart As String
Dim i As Integer
Dim j As Integer
strPath = "C:\PortableRvR\report\"
strFile = Dir(strPath & "*.csv")
i = 1
Do While strFile <> ""
With ActiveWorkbook.Worksheets.Add
With .QueryTables.Add(Connection:="TEXT;" & strPath & strFile, _
Destination:=.Range("A1"))
Parent.Name = Replace(strFile, ".csv", "")
TextFileParseType = xlDelimited
TextFileTextQualifier = xlTextQualifierDoubleQuote
TextFileConsecutiveDelimiter = False
TextFileTabDelimiter = False
TextFileSemicolonDelimiter = False
TextFileCommaDelimiter = True
TextFileSpaceDelimiter = False
TextFileColumnDataTypes = Array(1)
TextFileTrailingMinusNumbers = True
Refresh BackgroundQuery:=False
Files(i) = .Parent.Name
i = i + 1
End With
End With
strFile = Dir
Loop
numOfFiles = i - 1
chartName = "Chart 1"
For j = 1 To numOfFiles
strFile = Files(j)
Sheets(strFile).Select
Plot_y = Range("B1", Selection.End(xlDown)).Rows.Count
Plot_x = Range("C1", Selection.End(xlDown)).Rows.Count
Sheets("GraphDisplay").Select
If j = 1 Then ActiveSheet.ChartObjects(chartName).Activate
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(j).Name = strFile
ActiveChart.SeriesCollection(j).XValues = Sheets(strFile).Range("C1:C" & Plot_x)
ActiveChart.SeriesCollection(j).Values = Sheets(strFile).Range("B1:B" & Plot_y)
ActiveChart.SeriesCollection(j).MarkerStyle = -4142
ActiveChart.SeriesCollection(j).Smooth = False
Next j
ActiveSheet.ChartObjects(chartName).Activate
ActiveChart.Axes(xlValue).DisplayUnit = xlMillions
ActiveChart.Axes(xlValue).HasDisplayUnitLabel = False
End Sub
you can add 2 series for every file (j and j+1 inside for j = 1 to 2*numOfFiles step 2) and repeat everything for j+1 series except:
ActiveChart.SeriesCollection(j).Values = Sheets(strFile).Range("A1:A" & Plot_y)
ActiveChart.SeriesCollection(j+1).Values = Sheets(strFile).Range("B1:B" & Plot_y)
Not for points
I was planning to post this as a comment (and hence do not select this as an answer. All credit to #Aprillion) but the comment would not have formatted the code as this post would have done.
Whenever you add a series as Aprillion mentioned you have to also add one more line. I just tested this with small piece of data and it works.
'<~~ You have to call this everytime you add a new series
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(1).Values = "=Sheet1!$B$1:$B$6"
'<~~ You have to call this everytime you add a new series
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(2).Values = "=Sheet1!$A$1:$A$6"
Also since there is a huge difference between your Series 1 Data and Series 2 data (as per the snapshot), the 2nd series will be very close to X Axis.
Hope this is what you wanted?
FOLLOWUP
Is this what you are trying?
Dim files(1 To 20) As String
Dim numOfFiles As Integer
Dim chartName As String, shName as String
Sub Time_Graph()
Dim strPath As String, strFile As String, strChart As String
Dim i As Long, j As Long, n As Long
strPath = "C:\PortableRvR\report\"
strFile = Dir(strPath & "*.csv")
i = 1
Do While strFile <> ""
With ActiveWorkbook.Worksheets.Add
shName = strFile
ActiveSheet.Name = Replace(shName, ".csv", "")
With .QueryTables.Add(Connection:="TEXT;" & strPath & strFile, _
Destination:=.Range("A1"))
.Name = Replace(strFile, ".csv", "")
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
files(i) = .Parent.Name
i = i + 1
End With
End With
strFile = Dir
Loop
numOfFiles = i - 1
chartName = "Chart 1"
For j = 1 To numOfFiles
If n = 0 Then n = j Else n = n + 2
strFile = files(j)
Sheets(strFile).Select
Plot_y = Range("B1", Selection.End(xlDown)).Rows.Count
Plot_x = Range("C1", Selection.End(xlDown)).Rows.Count
Sheets("GraphDisplay").Select
If j = 1 Then ActiveSheet.ChartObjects(chartName).Activate
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(n).Name = strFile & " - Col B Values"
ActiveChart.SeriesCollection(n).XValues = "=" & strFile & "!$C$1:$C$" & Plot_x
ActiveChart.SeriesCollection(n).Values = "=" & strFile & "!$B$1:$B$" & Plot_y
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(n + 1).Name = strFile & " - Col A Values"
ActiveChart.SeriesCollection(n + 1).XValues = "=" & strFile & "!$C$1:$C$" & Plot_x
ActiveChart.SeriesCollection(n + 1).Values = "=" & strFile & "!$A$1:$A$" & Plot_y
ActiveChart.SeriesCollection(j).MarkerStyle = -4142
ActiveChart.SeriesCollection(j).Smooth = False
ActiveChart.SeriesCollection(n + 1).MarkerStyle = -4142
ActiveChart.SeriesCollection(n + 1).Smooth = False
Next j
ActiveSheet.ChartObjects(chartName).Activate
ActiveChart.Axes(xlValue).DisplayUnit = xlMillions
ActiveChart.Axes(xlValue).HasDisplayUnitLabel = False
End Sub
I have a workbook that contains a macro that i wish to use to update the location of a connection in another workbook. The VBA script creates a folder, populates it with a log file containing data called log.txt and a copy of an excel file that is pre formatted to fill with the data allowing the user to see graphs and a detailed breakdown of the data. it is a door opening log, tracking numbers of times the door has been used.
here is the VBA code I've come up with so far.
note: I did a couple of years programming in C++ but haven't touched it in a decade. I have tried searching around for the code and even recording a macro of the actions I take when refreshing the connection manually. however if I try and use that code it gives a "Run time error 1004" Application defined or object defined error.
Here is the code. The commented out bit at the bottom is the result of the macro recorded from manually altering the connection.
Any help would be greatly received.
Sub Lof_File_Macro()
' Log_file_Macro Macro
' Runs script for monthly counts '
Dim strfolder1, strmonthno, strmonth, stryear, strfoldername, strfile, strmonyr, stlogfile, strfutfile
'date strings defined using date functions - ofset for 28 days to allow running anytime within 20 days into the next month whilereturning correct month
strmonthno = Month(Date - 28)
strmonth = MonthName((strmonthno), True)
stryear = Year(Date - 28)
strmonyr = " " & strmonth & " " & stryear
strfolder = "C:\Users\jtaylor7\Desktop\futures\People Counter" & strmonyr
strfile = "Futures People" & strmonyr & ".xls"
strlogfile = strfolder & "\" & "log" & strmonyr & ".txt"
strfutfile = strfolder & "\" & strfile
MkDir (strfolder)
FileCopy "C:\Users\jtaylor7\Desktop\futures\log.log", strlogfile
FileCopy "C:\Users\jtaylor7\Desktop\futures\template.xls", strfutfile
'Workbooks.Open Filename:=strfutfile
'ActiveWorkbook.Connections.AddFromFile (strlogfile)
'
'
' Perform data connection modification on file
'' Windows(strfutfile).Activate
' With ActiveWorkbook.Connections("log")
' .Name = "log"
' .Description = ""
' End With
' Range("$A$1:$H$1").Select
'With Selection.QueryTable
' .Connection = "TEXT;strlogfile"
' .TextFilePlatform = 850
' .TextFileStartRow = 1
' .TextFileParseType = xlDelimited
' .TextFileTextQualifier = xlTextQualifierDoubleQuote
' .TextFileConsecutiveDelimiter = False
' .TextFileTabDelimiter = False
' .TextFileSemicolonDelimiter = False
' .TextFileCommaDelimiter = True
' .TextFileSpaceDelimiter = False
' .TextFileOtherDelimiter = "/"
' .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
' .TextFileTrailingMinusNumbers = True
' .Refresh BackgroundQuery:=False
' End With
' Range("I4").Select
' ActiveWorkbook.Connections("log").Refresh
'' Windows("Run Me.xls").Activate
'
End Sub
I know its a bit messy, and if anyone needs any further data please ask.
Something like this should do the trick.
Pls update your paths from my testing below
Sub LogFile_Macro()
Dim strFolder As String
Dim strMonthno As String
Dim strMonth As String
Dim strYear As String
Dim strFoldername As String
Dim strFile As String
Dim strMonyr As String
Dim strLogfile As String
Dim strFutfile As String
Dim wb As Workbook
'date strings defined using date functions - ofset for 28 days to allow running anytime within 20 days into the next month whilereturning correct month
strMonthno = Month(Date - 28)
strMonth = MonthName((strMonthno), True)
strYear = Year(Date - 28)
strMonyr = " " & strMonth & " " & strYear
strFolder = "C:\temp\People Counter" & strMonyr
strFile = "Futures People" & strMonyr & ".xls"
strLogfile = strFolder & "\" & "log" & strMonyr & ".txt"
strFutfile = strFolder & "\" & strFile
On Error Resume Next
MkDir strFolder
If Err.Number <> 0 Then
MsgBox "cannot create path", vbCritical
Exit Sub
End If
On Error GoTo 0
FileCopy "C:\temp\futures\log.log", strLogfile
FileCopy "C:\temp\futures\template.xls", strFutfile
Set wb = Workbooks.Open(strFutfile)
With wb.Sheets(1).QueryTables.Add(Connection:="TEXT;" & strLogfile, Destination:=Range("A1:H1"))
.Name = "log"
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileCommaDelimiter = True
.TextFileOtherDelimiter = "/"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
.Refresh
End With
Windows("Run Me.xls").Activate
End Sub