1.参数化生成Grid
a GH的【坐标】数据整理为EXCEL
Sub ReorganizeDataWithBracketExtraction()Dim ws As WorksheetDim lastRow As LongDim lastCol As LongDim i As Long, j As LongDim cellValue As StringDim colIndex As LongDim newRow As LongDim targetCol As Long' 设置工作表Set ws = ActiveSheet' 找到数据的最后一行和最后一列lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).RowlastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column' 创建新工作表Dim newWs As WorksheetSet newWs = Worksheets.AddnewWs.Name = "PointCoord_Data"' 设置表头newWs.Cells(1, 1).value = "No."' 处理原始数据For j = 1 To lastColFor i = 1 To lastRowcellValue = Trim(ws.Cells(i, j).value)' 检查是否以{数字}开头If cellValue <> "" And Left(cellValue, 1) = "{" Then' 提取大括号中的数字Dim bracketPos As LongbracketPos = InStr(cellValue, "}")If bracketPos > 1 ThenDim numberStr As StringnumberStr = Mid(cellValue, 2, bracketPos - 2)' 检查是否为数字If IsNumeric(numberStr) ThentargetCol = Val(numberStr) + 2 ' +2因为从B列开始' 设置列标题 (A, B, C, D...)If newWs.Cells(1, targetCol).value = "" ThennewWs.Cells(1, targetCol).value = GetColumnLetter(Val(numberStr) + 1)End If' 找到目标列的下一个空行（从第2行开始）newRow = newWs.Cells(newWs.Rows.Count, targetCol).End(xlUp).Row + 1If newWs.Cells(2, targetCol).value = "" Then newRow = 2' 复制数据列表到新位置Dim currentRow As LongcurrentRow = i + 1 ' 跳过{n}行本身' 复制{n}后面的所有连续数据Do While currentRow <= lastRowDim currentValue As StringcurrentValue = Trim(ws.Cells(currentRow, j).value)' 如果为空或遇到下一个{n}模式则停止If currentValue = "" Then Exit DoIf Left(currentValue, 1) = "{" And InStr(currentValue, "}") > 1 Then Exit Do' 清理数据：只保留花括号内的内容Dim cleanedValue As StringcleanedValue = ExtractBracketContent(currentValue)If cleanedValue <> "" ThennewWs.Cells(newRow, targetCol).value = cleanedValuenewRow = newRow + 1End IfcurrentRow = currentRow + 1LoopEnd IfEnd IfEnd IfNext iNext j' 添加行号到第一列（从A2开始）Dim rowCount As LongrowCount = 1' 找到实际有数据的最后一行Dim dataLastRow As LongdataLastRow = 1For i = 2 To 50 ' 检查前50列Dim tempLastRow As LongtempLastRow = newWs.Cells(newWs.Rows.Count, i).End(xlUp).RowIf tempLastRow > dataLastRow ThendataLastRow = tempLastRowEnd IfNext i' 添加行号For i = 2 To dataLastRownewWs.Cells(i, 1).value = rowCountrowCount = rowCount + 1Next i' 找到有数据的最后一列Dim dataLastCol As LongdataLastCol = 1For i = 2 To 50If newWs.Cells(1, i).value <> "" ThendataLastCol = iEnd IfNext 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 ThenDim dataRange As RangeSet dataRange = .Range(.Cells(1, 1), .Cells(dataLastRow, dataLastCol))With dataRange.Borders.LineStyle = xlContinuous.Weight = xlThinEnd With' 设置标题背景.Rows(1).Interior.Color = RGB(220, 220, 220).Columns(1).Interior.Color = RGB(240, 240, 240)End IfEnd With' 激活新工作表newWs.ActivatenewWs.Range("A1").SelectMsgBox "数据整理完成！" & vbCrLf & _"? 数据从B列开始排列" & vbCrLf & _"? 第一行显示字母标号(A,B,C...)" & vbCrLf & _"? 第一列显示数字编号(1,2,3...)" & vbCrLf & _"? 只保留花括号{}内的内容" & vbCrLf & _"新工作表: " & newWs.Name
End Sub' 函数：提取花括号内的内容
Function ExtractBracketContent(inputValue As String) As StringDim result As StringDim startPos As LongDim endPos As LongDim tempResult As Stringresult = ""startPos = 1' 查找所有花括号内的内容DostartPos = InStr(startPos, inputValue, "{")If startPos = 0 Then Exit DoendPos = InStr(startPos, inputValue, "}")If endPos = 0 Then Exit Do' 提取花括号内的内容tempResult = Mid(inputValue, startPos + 1, endPos - startPos - 1)' 如果结果不为空，添加到总结果中If Trim(tempResult) <> "" ThenIf result <> "" Thenresult = result & "," & Trim(tempResult)Elseresult = Trim(tempResult)End IfEnd IfstartPos = endPos + 1Loop' 如果没找到花括号，检查是否有纯数字（用逗号分隔）If result = "" Then' 移除所有非数字、非逗号、非空格、非负号、非小数点的字符Dim cleanStr As StringDim i As LongDim char As StringcleanStr = ""For i = 1 To Len(inputValue)char = Mid(inputValue, i, 1)If IsNumeric(char) Or char = "," Or char = " " Or char = "-" Or char = "." ThencleanStr = cleanStr & charEnd IfNext i' 清理多余的空格和逗号cleanStr = Trim(cleanStr)Do While InStr(cleanStr, " ") > 0cleanStr = Replace(cleanStr, " ", " ")LoopDo While InStr(cleanStr, " ,") > 0cleanStr = Replace(cleanStr, " ,", ",")LoopDo While InStr(cleanStr, ", ") > 0cleanStr = 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 IfExtractBracketContent = result
End Function' 函数：将数字转换为字母
Function GetColumnLetter(colNum As Long) As StringDim result As StringDim temp As LongDotemp = colNum Mod 26If temp = 0 Thenresult = "Z" & resultcolNum = colNum \ 26 - 1Elseresult = Chr(64 + temp) & resultcolNum = colNum \ 26End IfLoop While colNum > 0GetColumnLetter = result
End Function
a GH的【点编号】数据整理为EXCEL
Sub ReorganizeDataWithBracketExtraction()Dim ws As WorksheetDim lastRow As LongDim lastCol As LongDim i As Long, j As LongDim cellValue As StringDim colIndex As LongDim newRow As LongDim targetCol As Long' 设置工作表Set ws = ActiveSheet' 找到数据的最后一行和最后一列lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).RowlastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column' 创建新工作表Dim newWs As WorksheetSet newWs = Worksheets.AddnewWs.Name = "PointName_Data"' 设置表头newWs.Cells(1, 1).value = "No."' 调试信息Debug.Print "开始处理，数据范围: " & lastRow & " 行, " & lastCol & " 列"' 处理原始数据For j = 1 To lastColFor i = 1 To lastRowcellValue = Trim(CStr(ws.Cells(i, j).value))' 输出所有非空单元格内容进行调试If cellValue <> "" ThenDebug.Print "单元格(" & i & "," & j & "): [" & cellValue & "]"End If' 检查是否以{数字}开头If cellValue <> "" And Left(cellValue, 1) = "{" ThenDebug.Print "*** 找到花括号标识符: " & cellValue' 提取大括号中的数字Dim bracketPos As LongbracketPos = InStr(cellValue, "}")If bracketPos > 1 ThenDim numberStr As StringnumberStr = Mid(cellValue, 2, bracketPos - 2)Debug.Print "提取的数字字符串: [" & numberStr & "]"' 检查是否为数字If IsNumeric(numberStr) ThenDim colNumber As LongcolNumber = Val(numberStr)targetCol = colNumber + 2 ' +2因为从B列开始Debug.Print "列号: " & colNumber & ", 目标列: " & targetCol' 设置列标题 (A, B, C, D...)If newWs.Cells(1, targetCol).value = "" ThennewWs.Cells(1, targetCol).value = GetColumnLetter(colNumber + 1)Debug.Print "设置列标题: " & GetColumnLetter(colNumber + 1) & " 在列 " & targetColEnd If' 找到目标列的下一个空行（从第2行开始）newRow = newWs.Cells(newWs.Rows.Count, targetCol).End(xlUp).Row + 1If newWs.Cells(2, targetCol).value = "" Then newRow = 2Debug.Print "开始写入行: " & newRow' 复制数据列表到新位置Dim currentRow As LongcurrentRow = i + 1 ' 跳过{n}行本身' 复制{n}后面的所有连续数据Do While currentRow <= lastRowDim currentValue As StringcurrentValue = Trim(CStr(ws.Cells(currentRow, j).value))Debug.Print "检查数据行(" & currentRow & "," & j & "): [" & currentValue & "]"' 如果为空则停止If currentValue = "" ThenDebug.Print "遇到空行，停止"Exit DoEnd If' 如果遇到下一个{n}模式则停止If Left(currentValue, 1) = "{" And InStr(currentValue, "}") > 1 ThenDebug.Print "遇到下一个花括号标识符，停止: " & currentValueExit DoEnd If' 清理数据：移除序号前缀（如 "7. FTA8" -> "FTA8"）Dim cleanedValue As StringcleanedValue = RemoveNumberPrefix(currentValue)Debug.Print "清理前: [" & currentValue & "] -> 清理后: [" & cleanedValue & "]"If cleanedValue <> "" ThennewWs.Cells(newRow, targetCol).value = cleanedValueDebug.Print "写入数据到(" & newRow & "," & targetCol & "): " & cleanedValuenewRow = newRow + 1End IfcurrentRow = currentRow + 1LoopElseDebug.Print "花括号内不是数字: " & numberStrEnd IfElseDebug.Print "未找到右花括号"End IfEnd IfNext iNext j' 添加行号到第一列（从A2开始）Dim rowCount As LongrowCount = 1' 找到实际有数据的最后一行Dim dataLastRow As LongdataLastRow = 1For i = 2 To 50 ' 检查前50列Dim tempLastRow As LongtempLastRow = newWs.Cells(newWs.Rows.Count, i).End(xlUp).RowIf tempLastRow > dataLastRow ThendataLastRow = tempLastRowEnd IfNext iDebug.Print "数据最后一行: " & dataLastRow' 添加行号For i = 2 To dataLastRownewWs.Cells(i, 1).value = rowCountrowCount = rowCount + 1Next i' 找到有数据的最后一列Dim dataLastCol As LongdataLastCol = 1For i = 2 To 50If newWs.Cells(1, i).value <> "" ThendataLastCol = iEnd IfNext iDebug.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 ThenDim dataRange As RangeSet dataRange = .Range(.Cells(1, 1), .Cells(dataLastRow, dataLastCol))With dataRange.Borders.LineStyle = xlContinuous.Weight = xlThinEnd With' 设置标题背景.Rows(1).Interior.Color = RGB(220, 220, 220).Columns(1).Interior.Color = RGB(240, 240, 240)End IfEnd With' 激活新工作表newWs.ActivatenewWs.Range("A1").SelectMsgBox "数据整理完成！" & vbCrLf & _"? 处理了 " & (dataLastCol - 1) & " 列数据" & vbCrLf & _"? 共 " & (dataLastRow - 1) & " 行数据" & vbCrLf & _"? 已移除所有序号前缀" & vbCrLf & _"? 请查看立即窗口(Ctrl+G)的调试信息" & vbCrLf & _"新工作表: " & newWs.Name
End Sub' 函数：移除数据项前面的序号（如 "7. FTA8" -> "FTA8"）
Function RemoveNumberPrefix(inputValue As String) As StringDim result As StringDim value As StringDim i As Longvalue = Trim(inputValue)result = value' 查找 "数字." 模式For i = 1 To Len(value)Dim char As Stringchar = Mid(value, i, 1)If IsNumeric(char) Then' 继续查找数字ElseIf char = "." Then' 找到点号，提取后面的内容If i < Len(value) Thenresult = Trim(Mid(value, i + 1))' 移除可能的前导空格Do While Left(result, 1) = " "result = Mid(result, 2)LoopEnd IfExit ForElseIf char = " " Then' 如果遇到空格且前面都是数字，也认为是序号Dim beforeSpace As StringbeforeSpace = Left(value, i - 1)If IsNumeric(beforeSpace) Thenresult = Trim(Mid(value, i + 1))End IfExit ForElse' 遇到非数字非点号字符，不是序号格式Exit ForEnd IfNext iRemoveNumberPrefix = result
End Function' 函数：将数字转换为字母
Function GetColumnLetter(colNum As Long) As StringDim result As StringDim temp As LongDotemp = colNum Mod 26If temp = 0 Thenresult = "Z" & resultcolNum = colNum \ 26 - 1Elseresult = Chr(64 + temp) & resultcolNum = colNum \ 26End IfLoop While colNum > 0GetColumnLetter = result
End Function
