'Merging csv files deletes data
I need to choose and merge multiple csv files. All are in the same structure, however the name of file and sheets change. The separator is ;
The code merges the data but seems to delete some rows. Because after the merge it ruins the structure and after I want to transfer data to column it says the data is already there do you want to delete it?
And the transformation deletes some rows.
Sub mergeAllFiles_MULTIPLE()
Dim This As Workbook 'Store the book with the macro
Dim TmpB As Workbook 'store the book that has the sheets (one per book)
Dim AllB As Workbook 'book to send all the books
Dim sht As Worksheet 'the only sheet every book
Dim FileNames As Variant
Dim Msg As String
Dim I As Integer
Set This = ThisWorkbook
FileNames = Application.GetOpenFilename(MultiSelect:=True)
If IsArray(FileNames) Then
Workbooks.Add 'add a new book to store all the sheets
Set AllB = ActiveWorkbook
AllB.SaveAs This.Path & "\allSheetsInOne" & SetTimeName & ".xlsx", 51
'The function is to store a different name every time and avoid error
Msg = "You selected:" & vbNewLine
For I = LBound(FileNames) To UBound(FileNames)
Workbooks.Open FileName:=FileNames(I)
Set TmpB = ActiveWorkbook
TmpB.Activate
Set sht = ActiveSheet 'because you say that the book has only one sheet
sht.Copy Before:=AllB.Sheets(Sheets.Count) 'send it to the end of the sheets
TmpB.Close 'we don't need the book anymore
Set TmpB = Nothing 'empty the var to use it again
Set sht = Nothing
Msg = Msg & FileNames(I) & vbNewLine
Next
'UpdatebyExtendoffice
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Master"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
'DELETESHIT
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Master" Then
xWs.Delete
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
(20, 1), Array(21, 1), Array(22, 1)), TrailingMinusNumbers:=True
ActiveSheet.Range("$A$1:$XFD$1048576").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, _
34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, _
60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80), Header:=xlNo
End If
End Sub
Function SetTimeName()
Dim YY
Dim MM
Dim DD
Dim HH
Dim MI
Dim SS
Dim TT
YY = Year(Date)
MM = Month(Date)
DD = Day(Date)
HH = Hour(Now)
MI = Minute(Now)
SS = Second(Now)
TT = Format(YY, "0000") & Format(MM, "00") & Format(DD, "00") & Format(HH, "00") & Format(MI, "00") & Format(SS, "00")
SetTimeName = TT
End Function
If I removed the condition to resume next. The error is given at
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
After the merge of the files, in some rows it separates the data to 2 columns not just in 1.
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|
