Untitled
Guest 220 14th May, 2024
Function CreateUniqueWorksheet(wsNamePrefix As String) As Worksheet
Dim ws As Worksheet
Dim suffix As Integer
Dim wsName As String
Dim wsExists As Boolean
suffix = 1
wsName = wsNamePrefix & "_" & suffix
' Sprawdzanie, czy arkusz istnieje
Do
wsExists = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = wsName Then
wsExists = True
Exit For
End If
Next ws
If wsExists Then
suffix = suffix + 1
wsName = wsNamePrefix & "_" & suffix
Else
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = wsName
End If
Loop While wsExists
Set CreateUniqueWorksheet = ws
End Function
Sub CreateDataSheet()
Dim filePath As String
filePath = GetFilePath()
If filePath = "" Then Exit Sub
Dim fileNum As Integer
Dim textLine As String
Dim conditionName As String
Dim currentColumn As Integer
Dim ws As Worksheet
Dim lines() As String
Dim dataStartRow As Integer
Dim emptyLineCounter As Integer
fileNum = FreeFile()
Open filePath For Input As fileNum
Set ws = CreateUniqueWorksheet("ST1") ' Utwórz arkusz z unikalną nazwą
currentColumn = 1
emptyLineCounter = 0
' Read all text and handle different new line characters
Dim allText As String
allText = Input$(LOF(fileNum), fileNum)
allText = Replace(allText, vbCrLf, vbLf) ' Normalize new lines to Unix-style
lines = Split(allText, vbLf) ' Split into lines using Unix-style new line
Close fileNum
Dim i As Long
For i = LBound(lines) To UBound(lines)
textLine = Trim(lines(i))
If textLine Like "*CONDITION NO.*" And i + 4 <= UBound(lines) Then
conditionName = ExtractConditionName(lines(i + 4))
SetHeaders ws, currentColumn, conditionName
dataStartAllText = i + 19
If dataStartRow <= UBound(lines) Then
emptyLineCounter = 0
Dim dataRow As Integer
dataRow = 4
While dataStartRow <= UBound(lines) And emptyLineCounter < 2
If Trim(lines(dataStartRow)) = "" Then
emptyLineCounter = emptyAllText+ 1
Else
emptyLineCounter = 0
FillData ws, lines(dataStartRow), currentColumn, dataRow, 19
dataRow = dataRow + 1
End If
dataStartRow = dataStartRow + 1
Wend
currentColumn = currentColumn + 20
End If
End If
Next i
MsgBox "Data processing completed and organized in the worksheet."
End Sub
To share this paste please copy this url and send to your friends
RAW Paste Data
Recent Pastes
- Untitled
Markup | 9 | 2 hours ago
- Untitled
Markup | 9 | 2 hours ago
- Untitled
Markup | 11 | 3 hours ago
- Untitled
Markup | 17 | 9 hours ago
- Untitled
Markup | 15 | 16 hours ago
- The significance of implementing charismatic gifts in the congregation
Pure | 9 | 18 hours ago
- Untitled
Markup | 26 | 1 day ago