【Settlement】P1：整理GH中的矩形GRID角点到EXCEL中

1.参数化生成Grid

a GH的【坐标】数据整理为EXCEL

c 复制代码

Sub ReorganizeDataWithBracketExtraction()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim i As Long, j As Long
    Dim cellValue As String
    Dim colIndex As Long
    Dim newRow As Long
    Dim targetCol As Long
    
    ' 设置工作表
    Set ws = ActiveSheet
    
    ' 找到数据的最后一行和最后一列
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 创建新工作表
    Dim newWs As Worksheet
    Set newWs = Worksheets.Add
    newWs.Name = "PointCoord_Data"
    
    ' 设置表头
    newWs.Cells(1, 1).value = "No."
    
    ' 处理原始数据
    For j = 1 To lastCol
        For i = 1 To lastRow
            cellValue = Trim(ws.Cells(i, j).value)
            
            ' 检查是否以{数字}开头
            If cellValue <> "" And Left(cellValue, 1) = "{" Then
                ' 提取大括号中的数字
                Dim bracketPos As Long
                bracketPos = InStr(cellValue, "}")
                
                If bracketPos > 1 Then
                    Dim numberStr As String
                    numberStr = Mid(cellValue, 2, bracketPos - 2)
                    
                    ' 检查是否为数字
                    If IsNumeric(numberStr) Then
                        targetCol = Val(numberStr) + 2 ' +2因为从B列开始
                        
                        ' 设置列标题 (A, B, C, D...)
                        If newWs.Cells(1, targetCol).value = "" Then
                            newWs.Cells(1, targetCol).value = GetColumnLetter(Val(numberStr) + 1)
                        End If
                        
                        ' 找到目标列的下一个空行（从第2行开始）
                        newRow = newWs.Cells(newWs.Rows.Count, targetCol).End(xlUp).Row + 1
                        If newWs.Cells(2, targetCol).value = "" Then newRow = 2
                        
                        ' 复制数据列表到新位置
                        Dim currentRow As Long
                        currentRow = i + 1 ' 跳过{n}行本身
                        
                        ' 复制{n}后面的所有连续数据
                        Do While currentRow <= lastRow
                            Dim currentValue As String
                            currentValue = Trim(ws.Cells(currentRow, j).value)
                            
                            ' 如果为空或遇到下一个{n}模式则停止
                            If currentValue = "" Then Exit Do
                            If Left(currentValue, 1) = "{" And InStr(currentValue, "}") > 1 Then Exit Do
                            
                            ' 清理数据：只保留花括号内的内容
                            Dim cleanedValue As String
                            cleanedValue = ExtractBracketContent(currentValue)
                            
                            If cleanedValue <> "" Then
                                newWs.Cells(newRow, targetCol).value = cleanedValue
                                newRow = newRow + 1
                            End If
                            
                            currentRow = currentRow + 1
                        Loop
                    End If
                End If
            End If
        Next i
    Next j
    
    ' 添加行号到第一列（从A2开始）
    Dim rowCount As Long
    rowCount = 1
    
    ' 找到实际有数据的最后一行
    Dim dataLastRow As Long
    dataLastRow = 1
    For i = 2 To 50 ' 检查前50列
        Dim tempLastRow As Long
        tempLastRow = newWs.Cells(newWs.Rows.Count, i).End(xlUp).Row
        If tempLastRow > dataLastRow Then
            dataLastRow = tempLastRow
        End If
    Next i
    
    ' 添加行号
    For i = 2 To dataLastRow
        newWs.Cells(i, 1).value = rowCount
        rowCount = rowCount + 1
    Next i
    
    ' 找到有数据的最后一列
    Dim dataLastCol As Long
    dataLastCol = 1
    For i = 2 To 50
        If newWs.Cells(1, i).value <> "" Then
            dataLastCol = i
        End If
    Next i
    
    ' 格式化工作表
    With newWs
        .Cells.Font.Name = "Arial"
        .Cells.Font.Size = 10
        .Rows(1).Font.Bold = True
        .Columns(1).Font.Bold = True
        .Columns.AutoFit
        
        ' 设置边框
        If dataLastRow > 1 And dataLastCol > 1 Then
            Dim dataRange As Range
            Set dataRange = .Range(.Cells(1, 1), .Cells(dataLastRow, dataLastCol))
            With dataRange.Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            
            ' 设置标题背景
            .Rows(1).Interior.Color = RGB(220, 220, 220)
            .Columns(1).Interior.Color = RGB(240, 240, 240)
        End If
    End With
    
    ' 激活新工作表
    newWs.Activate
    newWs.Range("A1").Select
    
    MsgBox "数据整理完成！" & vbCrLf & _
           "? 数据从B列开始排列" & vbCrLf & _
           "? 第一行显示字母标号(A,B,C...)" & vbCrLf & _
           "? 第一列显示数字编号(1,2,3...)" & vbCrLf & _
           "? 只保留花括号{}内的内容" & vbCrLf & _
           "新工作表: " & newWs.Name
End Sub

' 函数：提取花括号内的内容
Function ExtractBracketContent(inputValue As String) As String
    Dim result As String
    Dim startPos As Long
    Dim endPos As Long
    Dim tempResult As String
    
    result = ""
    startPos = 1
    
    ' 查找所有花括号内的内容
    Do
        startPos = InStr(startPos, inputValue, "{")
        If startPos = 0 Then Exit Do
        
        endPos = InStr(startPos, inputValue, "}")
        If endPos = 0 Then Exit Do
        
        ' 提取花括号内的内容
        tempResult = Mid(inputValue, startPos + 1, endPos - startPos - 1)
        
        ' 如果结果不为空，添加到总结果中
        If Trim(tempResult) <> "" Then
            If result <> "" Then
                result = result & "," & Trim(tempResult)
            Else
                result = Trim(tempResult)
            End If
        End If
        
        startPos = endPos + 1
    Loop
    
    ' 如果没找到花括号，检查是否有纯数字（用逗号分隔）
    If result = "" Then
        ' 移除所有非数字、非逗号、非空格、非负号、非小数点的字符
        Dim cleanStr As String
        Dim i As Long
        Dim char As String
        
        cleanStr = ""
        For i = 1 To Len(inputValue)
            char = Mid(inputValue, i, 1)
            If IsNumeric(char) Or char = "," Or char = " " Or char = "-" Or char = "." Then
                cleanStr = cleanStr & char
            End If
        Next i
        
        ' 清理多余的空格和逗号
        cleanStr = Trim(cleanStr)
        Do While InStr(cleanStr, "  ") > 0
            cleanStr = Replace(cleanStr, "  ", " ")
        Loop
        Do While InStr(cleanStr, " ,") > 0
            cleanStr = Replace(cleanStr, " ,", ",")
        Loop
        Do While InStr(cleanStr, ", ") > 0
            cleanStr = Replace(cleanStr, ", ", ",")
        Loop
        
        ' 移除开头和结尾的逗号
        If Left(cleanStr, 1) = "," Then cleanStr = Mid(cleanStr, 2)
        If Right(cleanStr, 1) = "," Then cleanStr = Left(cleanStr, Len(cleanStr) - 1)
        
        result = Trim(cleanStr)
    End If
    
    ExtractBracketContent = result
End Function

' 函数：将数字转换为字母
Function GetColumnLetter(colNum As Long) As String
    Dim result As String
    Dim temp As Long
    
    Do
        temp = colNum Mod 26
        If temp = 0 Then
            result = "Z" & result
            colNum = colNum \ 26 - 1
        Else
            result = Chr(64 + temp) & result
            colNum = colNum \ 26
        End If
    Loop While colNum > 0
    
    GetColumnLetter = result
End Function

a GH的【点编号】数据整理为EXCEL

c 复制代码

Sub ReorganizeDataWithBracketExtraction()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim i As Long, j As Long
    Dim cellValue As String
    Dim colIndex As Long
    Dim newRow As Long
    Dim targetCol As Long
    
    ' 设置工作表
    Set ws = ActiveSheet
    
    ' 找到数据的最后一行和最后一列
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 创建新工作表
    Dim newWs As Worksheet
    Set newWs = Worksheets.Add
    newWs.Name = "PointName_Data"
    
    ' 设置表头
    newWs.Cells(1, 1).value = "No."
    
    ' 调试信息
    Debug.Print "开始处理，数据范围: " & lastRow & " 行, " & lastCol & " 列"
    
    ' 处理原始数据
    For j = 1 To lastCol
        For i = 1 To lastRow
            cellValue = Trim(CStr(ws.Cells(i, j).value))
            
            ' 输出所有非空单元格内容进行调试
            If cellValue <> "" Then
                Debug.Print "单元格(" & i & "," & j & "): [" & cellValue & "]"
            End If
            
            ' 检查是否以{数字}开头
            If cellValue <> "" And Left(cellValue, 1) = "{" Then
                Debug.Print "*** 找到花括号标识符: " & cellValue
                
                ' 提取大括号中的数字
                Dim bracketPos As Long
                bracketPos = InStr(cellValue, "}")
                
                If bracketPos > 1 Then
                    Dim numberStr As String
                    numberStr = Mid(cellValue, 2, bracketPos - 2)
                    Debug.Print "提取的数字字符串: [" & numberStr & "]"
                    
                    ' 检查是否为数字
                    If IsNumeric(numberStr) Then
                        Dim colNumber As Long
                        colNumber = Val(numberStr)
                        targetCol = colNumber + 2 ' +2因为从B列开始
                        Debug.Print "列号: " & colNumber & ", 目标列: " & targetCol
                        
                        ' 设置列标题 (A, B, C, D...)
                        If newWs.Cells(1, targetCol).value = "" Then
                            newWs.Cells(1, targetCol).value = GetColumnLetter(colNumber + 1)
                            Debug.Print "设置列标题: " & GetColumnLetter(colNumber + 1) & " 在列 " & targetCol
                        End If
                        
                        ' 找到目标列的下一个空行（从第2行开始）
                        newRow = newWs.Cells(newWs.Rows.Count, targetCol).End(xlUp).Row + 1
                        If newWs.Cells(2, targetCol).value = "" Then newRow = 2
                        Debug.Print "开始写入行: " & newRow
                        
                        ' 复制数据列表到新位置
                        Dim currentRow As Long
                        currentRow = i + 1 ' 跳过{n}行本身
                        
                        ' 复制{n}后面的所有连续数据
                        Do While currentRow <= lastRow
                            Dim currentValue As String
                            currentValue = Trim(CStr(ws.Cells(currentRow, j).value))
                            
                            Debug.Print "检查数据行(" & currentRow & "," & j & "): [" & currentValue & "]"
                            
                            ' 如果为空则停止
                            If currentValue = "" Then
                                Debug.Print "遇到空行，停止"
                                Exit Do
                            End If
                            
                            ' 如果遇到下一个{n}模式则停止
                            If Left(currentValue, 1) = "{" And InStr(currentValue, "}") > 1 Then
                                Debug.Print "遇到下一个花括号标识符，停止: " & currentValue
                                Exit Do
                            End If
                            
                            ' 清理数据：移除序号前缀（如 "7. FTA8" -> "FTA8"）
                            Dim cleanedValue As String
                            cleanedValue = RemoveNumberPrefix(currentValue)
                            Debug.Print "清理前: [" & currentValue & "] -> 清理后: [" & cleanedValue & "]"
                            
                            If cleanedValue <> "" Then
                                newWs.Cells(newRow, targetCol).value = cleanedValue
                                Debug.Print "写入数据到(" & newRow & "," & targetCol & "): " & cleanedValue
                                newRow = newRow + 1
                            End If
                            
                            currentRow = currentRow + 1
                        Loop
                    Else
                        Debug.Print "花括号内不是数字: " & numberStr
                    End If
                Else
                    Debug.Print "未找到右花括号"
                End If
            End If
        Next i
    Next j
    
    ' 添加行号到第一列（从A2开始）
    Dim rowCount As Long
    rowCount = 1
    
    ' 找到实际有数据的最后一行
    Dim dataLastRow As Long
    dataLastRow = 1
    For i = 2 To 50 ' 检查前50列
        Dim tempLastRow As Long
        tempLastRow = newWs.Cells(newWs.Rows.Count, i).End(xlUp).Row
        If tempLastRow > dataLastRow Then
            dataLastRow = tempLastRow
        End If
    Next i
    
    Debug.Print "数据最后一行: " & dataLastRow
    
    ' 添加行号
    For i = 2 To dataLastRow
        newWs.Cells(i, 1).value = rowCount
        rowCount = rowCount + 1
    Next i
    
    ' 找到有数据的最后一列
    Dim dataLastCol As Long
    dataLastCol = 1
    For i = 2 To 50
        If newWs.Cells(1, i).value <> "" Then
            dataLastCol = i
        End If
    Next i
    
    Debug.Print "数据最后一列: " & dataLastCol
    
    ' 格式化工作表
    With newWs
        .Cells.Font.Name = "Arial"
        .Cells.Font.Size = 10
        .Rows(1).Font.Bold = True
        .Columns(1).Font.Bold = True
        .Columns.AutoFit
        
        ' 设置边框
        If dataLastRow > 1 And dataLastCol > 1 Then
            Dim dataRange As Range
            Set dataRange = .Range(.Cells(1, 1), .Cells(dataLastRow, dataLastCol))
            With dataRange.Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            
            ' 设置标题背景
            .Rows(1).Interior.Color = RGB(220, 220, 220)
            .Columns(1).Interior.Color = RGB(240, 240, 240)
        End If
    End With
    
    ' 激活新工作表
    newWs.Activate
    newWs.Range("A1").Select
    
    MsgBox "数据整理完成！" & vbCrLf & _
           "? 处理了 " & (dataLastCol - 1) & " 列数据" & vbCrLf & _
           "? 共 " & (dataLastRow - 1) & " 行数据" & vbCrLf & _
           "? 已移除所有序号前缀" & vbCrLf & _
           "? 请查看立即窗口(Ctrl+G)的调试信息" & vbCrLf & _
           "新工作表: " & newWs.Name
End Sub

' 函数：移除数据项前面的序号（如 "7. FTA8" -> "FTA8"）
Function RemoveNumberPrefix(inputValue As String) As String
    Dim result As String
    Dim value As String
    Dim i As Long
    
    value = Trim(inputValue)
    result = value
    
    ' 查找 "数字." 模式
    For i = 1 To Len(value)
        Dim char As String
        char = Mid(value, i, 1)
        
        If IsNumeric(char) Then
            ' 继续查找数字
        ElseIf char = "." Then
            ' 找到点号，提取后面的内容
            If i < Len(value) Then
                result = Trim(Mid(value, i + 1))
                ' 移除可能的前导空格
                Do While Left(result, 1) = " "
                    result = Mid(result, 2)
                Loop
            End If
            Exit For
        ElseIf char = " " Then
            ' 如果遇到空格且前面都是数字，也认为是序号
            Dim beforeSpace As String
            beforeSpace = Left(value, i - 1)
            If IsNumeric(beforeSpace) Then
                result = Trim(Mid(value, i + 1))
            End If
            Exit For
        Else
            ' 遇到非数字非点号字符，不是序号格式
            Exit For
        End If
    Next i
    
    RemoveNumberPrefix = result
End Function

' 函数：将数字转换为字母
Function GetColumnLetter(colNum As Long) As String
    Dim result As String
    Dim temp As Long
    
    Do
        temp = colNum Mod 26
        If temp = 0 Then
            result = "Z" & result
            colNum = colNum \ 26 - 1
        Else
            result = Chr(64 + temp) & result
            colNum = colNum \ 26
        End If
    Loop While colNum > 0
    
    GetColumnLetter = result
End Function