Public Sub subAppendDataFromTextFiles()
Dim fsoLibrary As FileSystemObject
Dim fsoFolder As Object
Dim sFileName As Object
Dim s As String
Dim arrFileName() As String
Dim dteStart As Date
Dim dteEnd As Date
Dim i As Integer
Dim WsProcess As Worksheet
Dim lngProcessLastRow As Long
Dim lngDestinationLastRow As Long
Dim rng As Range
Dim lngCount As Long
Dim Ws As Worksheet
Dim WsDestination As Worksheet
Dim WsLog As Worksheet
Dim strFolder As String
Dim intWorksheetUsedCount As Integer
Dim Wb As Workbook
' On Error GoTo Err_Handler
strFolder = "C:\Dump\Download Zip Files And Unzip\Downloads\Unzipped\"
ActiveWorkbook.Save
intWorksheetUsedCount = 1
Set Wb = ActiveWorkbook
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name Like "ImportedData*" Or Ws.Name = "FileLog" Then
Ws.Delete
End If
Next Ws
Application.DisplayAlerts = True
On Error GoTo 0
Worksheets.Add after:=Worksheets(Sheets.Count)
Set WsLog = ActiveSheet
With WsLog
.Name = "FileLog"
.Range("A1:B1").Value = Array("File Name", "Count")
End With
intWorksheetUsedCount = 1
Worksheets.Add after:=Worksheets(Sheets.Count)
Set WsDestination = ActiveSheet
With WsDestination
.Name = "ImportedData" & intWorksheetUsedCount
.Range("A1:D1").Value = Array("STATIONS_ID", "MESS_DATUM", "TT_10", "File Name")
End With
Set fsoLibrary = New FileSystemObject
Set fsoFolder = fsoLibrary.GetFolder(strFolder)
'Loop through each file in a folder.
For Each sFileName In fsoFolder.Files
On Error Resume Next
Application.DisplayAlerts = False
Wb.Worksheets("Process").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Workbooks.OpenText Filename:=sFileName, DataType:=xlDelimited, Semicolon:=True, DecimalSeparator:=",", ThousandsSeparator:="."
With ActiveWorkbook
.Sheets(1).Copy after:=Wb.Sheets(Wb.Sheets.Count)
.Close
End With
Set WsProcess = Wb.Sheets(Sheets.Count)
WsProcess.Name = "Process"
WsProcess.Range("A1").CurrentRegion.Columns(2).NumberFormat = "00"
WsProcess.Range("$C$1,$D$1,$F$1,$G$1,$H$1,$I$1").EntireColumn.Delete
' "STATIONS_ID", "MESS_DATUM" and "TT_10"
' Count the number of rows between 202305010010 and 202305312350.
lngProcessLastRow = WsProcess.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = WsProcess.Range("B2:B" & lngProcessLastRow)
lngCount = WorksheetFunction.CountIfs(rng, ">=" & 202305010010#, rng, "<=" & 202305312350#)
If lngCount > 0 Then
i = i + 1
WsLog.Range("A" & WsLog.Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(1, 2).Value = Array(Replace(sFileName, strFolder, "", 1), lngCount)
lngDestinationLastRow = WsDestination.Cells(Rows.Count, 1).End(xlUp).Row
' Is there enough room to paste the data?
If (lngDestinationLastRow + lngCount) > 500000 Then ' WsDestination.Rows.Count Then
Call subFormatWorksheet(WsDestination)
intWorksheetUsedCount = intWorksheetUsedCount + 1
Worksheets.Add after:=Worksheets(Sheets.Count)
Set WsDestination = ActiveSheet
WsDestination.Name = "ImportedData" & intWorksheetUsedCount
WsDestination.Range("A1:D1").Value = Array("STATIONS_ID", "MESS_DATUM", "TT_10", "File Name")
lngDestinationLastRow = 1
End If
If intWorksheetUsedCount >= 4000 Then
Exit Sub
End If
With WsProcess
.Range("$D$1").Value = "File Name"
.Range("$D$2:$D" & lngProcessLastRow).Value = Replace(sFileName, strFolder, "", 1)
.Range("$A$1:$D" & lngProcessLastRow).AutoFilter Field:=2, Criteria1:= _
">=202305010010", Operator:=xlAnd, Criteria2:="<=202305312350"
.Range("A2:D" & lngProcessLastRow).SpecialCells(xlCellTypeVisible).Copy
End With
WsDestination.Range("A" & lngDestinationLastRow + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next
'Release the memory.
Set fsoLibrary = Nothing
Set fsoFolder = Nothing
Call subFormatWorksheet(WsDestination)
Call subFormatWorksheet(WsLog)
Application.ScreenUpdating = True
MsgBox "All files have been imported.", vbOKOnly, "Confirmation"
Exit_Handler:
Exit Sub
Err_Handler:
MsgBox Err.Number & vbCrLf & _
Err.Description
Resume Exit_Handler
End Sub
Private Sub subFormatWorksheet(Ws As Worksheet)
With Ws.Range("A1").CurrentRegion
.Columns(2).NumberFormat = "00"
.Font.Size = 16
.EntireColumn.AutoFit
.RowHeight = 30
.VerticalAlignment = xlCenter
With .Rows(1)
.Interior.Color = RGB(213, 213, 213)
.Font.Bold = True
End With
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = vbBlack
End With
End With
End Sub
