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
                                
                            

Paste Hosted With By Wklejamy.pl