This allows user to select multiple .csv sheets and then summarises them, saving the summary alongside the originals. What I want to happen at the end is for the Macro enabled book to be left open so that the user can then do another summary, or manually close it. I cannot seem to get this to work. Second issue is that Userform remains open whilst the macro is running when I would ideally like it to close, not sure why it is doing this. I am very new to this and working to adapt coding written by a former colleague who knew a lot more about it than I do. Any help would be greatly appreciated.
Code:
Option Explicit
Private Sub OKButton_Click()
Dim CurrentBook As Workbook
Dim info As String
info = "UserForm 1 Matches"
Dim lastrow As Long
Dim length As Integer
Dim MyFileName As Variant
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets("Sheet2")
Dim IndvFiles As FileDialog
Dim FileIdx As Long
Dim i As Integer, x As Integer
Dim r As Range
Dim Sheet As Variant
Set IndvFiles = Application.FileDialog(msoFileDialogOpen)
With IndvFiles
.AllowMultiSelect = True
.Title = "Multi-select target data files:"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".csv files", "*.csv"
.Show
End With
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For FileIdx = 1 To IndvFiles.SelectedItems.Count
Set CurrentBook = Workbooks.Open(IndvFiles.SelectedItems(FileIdx))
For Each Sheet In CurrentBook.Sheets
Dim LRow1 As Long
LRow1 = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
Dim LRow2 As Long
LRow2 = CurrentBook.ActiveSheet.Range("A" & CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row
Dim ImportRange As Range
Set ImportRange = CurrentBook.ActiveSheet.Range("A2:Z" & LRow2)
ImportRange.Copy
WS.Range("A" & LRow1 + 1).PasteSpecial 'Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next
CurrentBook.Close False
Next FileIdx
'Check to see if correct converter is being used
'1. Check to see if data is from CT24 tracker
Application.Goto Reference:="R1C2"
If ActiveCell.Value = 0 Then ' the CT24 file has all data in Column A
Call Module1.ct24
Application.ScreenUpdating = False
Unload UserForm1
Application.Goto Reference:="R1C1"
Exit Sub
End If
End Sub
Option Explicit
Sub ct24()
On Error GoTo Err1:
Application.ScreenUpdating = False
Dim r As Range
Dim lastrow As Long
Dim x As Integer
Dim MyFileName As Variant
Dim length As Integer
Dim info As String
Dim CurrentBook As Workbook
info = "Module 1 - ct24"
With ActiveSheet
.Range("A1").Select
ActiveCell.FormulaR1C1 = "Number"
.Range("B1").Select
ActiveCell.FormulaR1C1 = "Latitude"
.Range("C1").Select
ActiveCell.FormulaR1C1 = "Longitude"
.Range("D1").Select
ActiveCell.FormulaR1C1 = "Day"
.Range("E1").Select
ActiveCell.FormulaR1C1 = "Date"
.Range("F1").Select
ActiveCell.FormulaR1C1 = "Speed"
.Range("G1").Select
ActiveCell.FormulaR1C1 = "Address"
.Range("H1").Select
ActiveCell.FormulaR1C1 = "Icon"
.Range("I1").Select
ActiveCell.FormulaR1C1 = "Stop Time"
.Range("J1").Select
ActiveCell.FormulaR1C1 = "Location "
.Range("K1").Select
ActiveCell.FormulaR1C1 = "Info"
'Copy Lat and Long columns and paste into two new columns
With ActiveSheet
.Rows(1).Find("Latitude").EntireColumn.Copy
.Columns("A:A").Select
Selection.Insert Shift:=xlToRight
.Rows(1).Find("Longitude").EntireColumn.Copy
.Columns("B:B").Select
Selection.Insert Shift:=xlToRight
.Columns("C:C").Select
Selection.Insert Shift:=xlToRight
.Range("C1").Select
ActiveCell.FormulaR1C1 = "Matches"
End With
'Sort data in whole sheet by Lat then Long to bring matching fixes together
Columns("A:O").Sort key1:=Range("A:A"), order1:=xlAscending, Header:=xlYes
Columns("A:O").Sort key1:=Range("B:B"), order1:=xlAscending, Header:=xlYes
'Round copied Lat and Long column data down to two or three decimal places for comparison dependent on user selection
If UserForm1.OptionButton1 Then
Set r = ActiveWorkbook.Worksheets("Sheet2").Range("A:A")
r.NumberFormat = "#0.000"
ActiveWorkbook.PrecisionAsDisplayed = True
Set r = ActiveWorkbook.Worksheets("Sheet2").Range("B:B")
r.NumberFormat = "#0.000"
ActiveWorkbook.PrecisionAsDisplayed = True
End If
If UserForm1.OptionButton2 Then
Set r = ActiveWorkbook.Worksheets("Sheet2").Range("A:A")
r.NumberFormat = "#0.00"
ActiveWorkbook.PrecisionAsDisplayed = True
Set r = ActiveWorkbook.Worksheets("Sheet2").Range("B:B")
r.NumberFormat = "#0.00"
ActiveWorkbook.PrecisionAsDisplayed = True
End If
'Look at first Lat value, compare with value in next Lat row. If the same then check if corresponding rows in Long column are also the same
With ActiveSheet
lastrow = Cells(Rows.Count, "A").End(xlUp).Row 'Find last row in column A
For x = 1 To lastrow
If Cells(x, 1).Value = Cells(x + 1, 1).Value And Cells(x, 2).Value = Cells(x + 1, 2).Value Then
Cells(x, 3).Value = "Match"
Cells(x + 1, 3).Value = "Match"
'If both Lat and Long match, sets value as Match in next column. Loops through whole sheet
End If
Next x
'Deletes non matching rows
With ActiveSheet
Range("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
'Delete comparison Lat and Long Columns
.Columns("A:B").Select
Selection.Delete
‘ Generate message box with results
Dim instances As Long
instances = WorksheetFunction.CountIf(Columns("A:A"), "Match")
If instances <> 0 Then _
MsgBox "Found " & instances & " Matches in current selection"
If instances = 0 Then _
MsgBox "No Matches Found In Current Selection"
End If
‘Save “Matches” File in same folder the raw data came from
MyFileName = "Matches.csv"
Application.DisplayAlerts = False
ActiveSheet.Columns("F:F").NumberFormat = "dd/mm/yyyy hh:mm:ss"
ActiveSheet.Columns("J:J").NumberFormat = "dd/mm/yyyy hh:mm:ss"
ActiveSheet.Columns("A:O").EntireColumn.AutoFit
ActiveSheet.SaveAs Filename:=MyFileName, FileFormat:=xlCSV
MsgBox "All Done - Next Please"
ThisWorkbook.Close False
Exit Sub
Err1:
MsgBox "Unexpected error - In " & info, , "Tell Fergie!"
Exit Sub
End With
End With
End Sub
