Pteroglossus
New Member
- Joined
- Nov 19, 2020
- Messages
- 14
- Office Version
- 365
- Platform
- Windows
Hi,
I' ve been working on a VBA script to automate a series of action I have to take on daily generated .csv files structured as follows:
The raw data is located in colums A to H, the script adds a "remark" column in I and then pastes various Countifs formulas in column J to AL.
The number of rows varies daily.
Using bits of code I found here and there, I've been able to write 7 steps but I'm now really stuck. Here is what I have so far:
The "Add total…" remark line is where I'm stuck. Using the macro recording tool, the code given works for the first iteration of script, but won’t work the loop part, as “Tableau1” will become “Tableau2” and so on.
I’ve been trying to refer to the table dynamically using the variables “Rtable” and “TabRng”, but either it’s not possible or I can’t get the syntax right.
Could anyone give me a hint?
Also, if you see anything else that could be improved please let me know
Best,
KL
I' ve been working on a VBA script to automate a series of action I have to take on daily generated .csv files structured as follows:
The raw data is located in colums A to H, the script adds a "remark" column in I and then pastes various Countifs formulas in column J to AL.
The number of rows varies daily.
Using bits of code I found here and there, I've been able to write 7 steps but I'm now really stuck. Here is what I have so far:
Excel Formula:
Sub Csv_proccessing_sequence()
Dim xFilesToOpen As Variant
Dim i As Integer
Dim xWb As Workbook
Dim xTempWb As Workbook
Dim xDelimiter As String
Dim xScreen As Boolean
Dim sourceColumn As Range, targetColumn As Range
Dim lastRow As Long
Dim lastColumn As Long
Dim Rtable As ListObject
Dim TblRng As Range
'1 - import csv file
On Error GoTo ErrHandler
xScreen = Application.ScreenUpdating
Application.ScreenUpdating = False
xDelimiter = ":"
xFilesToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "Kutools for Excel", , True)
If TypeName(xFilesToOpen) = "Boolean" Then
MsgBox "No files were selected", , "Kutools for Excel"
GoTo ExitHandler
End If
i = 1
Set xTempWb = Workbooks.Open(xFilesToOpen(i))
xTempWb.Sheets(1).Copy
Set xWb = Application.ActiveWorkbook
xTempWb.Close False
xWb.Worksheets(i).Columns("A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:=xDelimiter
'2 - delete columns D and I
Range("D:D,I:I").Delete
'3 - Add header column I
Cells(1, 9).Value = "Obs"
'4- Copy columns from Formula tab
Set sourceColumn = Workbooks("Import_txt_.xlsm").Worksheets(2).Columns("J:AM")
Set targetColumn = xWb.Worksheets(1).Columns("J:AM")
sourceColumn.Copy Destination:=targetColumn
targetColumn.ColumnWidth = sourceColumn.ColumnWidth
'5 - Define lastrow and last column and copy all formulas down
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
lastColumn = Cells(Columns.Count).End(xlToLeft).Column
Range("J4:AM4").Select
Selection.AutoFill Destination:=Range("J4:AM" & lastRow), Type:=xlFillCopy
'6 - Center all cells
With xWb.Worksheets(i).Cells
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
'7 - Turn into a referenced table
With xWb.Worksheets(i)
Set TblRng = .Range("A1", .Cells(lastRow, lastColumn))
Set Rtable = .ListObjects.Add(xlSrcRange, TblRng, , xlYes)
End With
'8 - 'Add "Total" and drag sum right
Rtable.ShowTotals = True
Rtable.ListColumns("Arr IFR").TotalsCalculation = xlTotalsCalculationSum
Range("Tableau1[[#Totals],[Arr IFR]]").Select
Selection.AutoFill Destination:=Range( _
"Tableau1[[#Totals],[Arr IFR]:[TDP/RDG]]"), Type:=xlFillDefault
Range("Tableau1[[#Totals],[Arr IFR]:[TDP/RDG]]").Select
Selection.Font.Size = 20
Selection.Font.Bold = True
' 9- loop
Do While i < UBound(xFilesToOpen)
i = i + 1
Set xTempWb = Workbooks.Open(xFilesToOpen(i))
With xWb
xTempWb.Sheets(1).Move after:=.Sheets(.Sheets.Count)
.Worksheets(i).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:=xDelimiter
'delete columns D and I
Range("D:D,I:I").Delete
'Add header column I
Cells(1, 9).Value = "Obs"
'Copy column from Formula tab
Set sourceColumn = Workbooks("Import_txt_.xlsm").Worksheets(2).Columns("J:AM")
Set targetColumn = xWb.Worksheets(i).Columns("J:AM")
sourceColumn.Copy Destination:=targetColumn
'Define lastrow and copy all formulas down
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
lastColumn = Cells(Columns.Count).End(xlToLeft).Column
Range("J4:AM4").Select
Selection.AutoFill Destination:=Range("J4:AM" & lastRow), Type:=xlFillCopy
'Center all cells
With xWb.Worksheets(i).Cells
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
'Turn into a table
With xWb.Worksheets(i)
Set TblRng = .Range("A1", .Cells(lastRow, lastColumn))
Set Table = .ListObjects.Add(xlSrcRange, TblRng, , xlYes)
Table.Name = "DynTable"
End With
'Display "total" line and drag sum formula right + font size
Rtable.ShowTotals = True
Rtable.ListColumns("Arr IFR").TotalsCalculation = _
xlTotalsCalculationSum
Range("Table, [[#Totals][Arr IFR]]").Select
Selection.AutoFill Destination:=Range( _
"Tableau(i)[[#Totals],[Arr IFR]:[TDP/RDG]]"), Type:=xlFillDefault
Range("Tableau(i)[[#Totals],[Arr IFR]:[TDP/RDG]]").Select
Selection.Font.Size = 20
End With
Loop
ExitHandler:
Application.ScreenUpdating = xScreen
Set xWb = Nothing
Set xTempWb = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, , "Kutools for Excel"
Resume ExitHandler
End SubThe "Add total…" remark line is where I'm stuck. Using the macro recording tool, the code given works for the first iteration of script, but won’t work the loop part, as “Tableau1” will become “Tableau2” and so on.
I’ve been trying to refer to the table dynamically using the variables “Rtable” and “TabRng”, but either it’s not possible or I can’t get the syntax right.
Could anyone give me a hint?
Also, if you see anything else that could be improved please let me know
Best,
KL
