NanjingBus VBA 源代码-CSDN博客

本文介绍了一种使用VBA自动格式化Excel中公交线路和站点信息的方法。该方法通过定义固定宽度的列来组织数据，并实现了自动合并单元格等功能，确保了公交线路和站点信息的清晰展示。

' version: 2008-10-10 Const sBusLineDetailSheet As String = "Bus Line Details" Const sBusStopDetailSheet As String = "Bus Stop Details" Const iHeaderColLen As Integer = 15 Const iValueColLen As Integer = 35 Private Sub FormatBusLines_Click() Dim iRowIndex As Integer, iPreRowIdx As Integer Dim objBusLineSheet As Worksheet Dim mergeRan As Range Set objBusLineSheet = Worksheets(sBusLineDetailSheet) With objBusLineSheet .Cells.ClearFormats .Cells.Font.Size = 11 '.Cells.Borders.LineStyle = xlContinuous '.Cells.Borders.Weight = xlThin .Cells.Borders.LineStyle = xlLineStyleNone '.Columns("A").Borders(xlEdgeRight).LineStyle = xlContinuous '.Columns("A").Borders(xlEdgeRight).Weight = xlMedium '.Columns("A").Borders(xlEdgeLeft).Weight = xlThick 'xlMedium '.Columns("A").UnMerge '.Columns("A").HorizontalAlignment = xlCenter '.Columns("A").VerticalAlignment = xlCenter '.Columns("K").Borders(xlEdgeRight).Weight = xlThick 'xlMedium '.Columns(1).ColumnWidth = 10 '.Columns(2).ColumnWidth = 255 Dim iMaxColNum As Integer, iMaxRowLen As Integer iMaxColNum = 10 'iMaxRowLen = (iHeaderColLen + iValueColLen) * (iMaxColNum - 2) + iValueColLen Dim i As Integer For i = 1 To iMaxColNum + 1 Step 2 .Columns(i).ColumnWidth = iHeaderColLen .Columns(i + 1).ColumnWidth = iValueColLen Next End With iRowIndex = 2 iPreRowIdx = iRowIndex Do While (Not isEmptyStr(objBusLineSheet.Cells(iRowIndex, 2).Value) And iPreRowIdx < 2000) 'MsgBox (objBusLineSheet.Cells(iRowIndex, 2).Value) ' With objBusLineSheet.Range(objBusLineSheet.Cells(iRowIndex, 2), objBusLineSheet.Cells(iRowIndex, iMaxColNum)) ' Dim strValue As String ' strValue = objBusLineSheet.Cells(iRowIndex, 2).Value ' ' Dim leng As Integer ' leng = .Width ' ' .Merge ' .WrapText = True ' '.AutoFit = True ' '.Rows.AutoFit = True ' ' .RowHeight = Int(leng / iMaxRowLen + 0.99999) * 15 ' ' End With If (isEmptyStr(objBusLineSheet.Cells(iRowIndex, 1).Value)) Then If (objBusLineSheet.Range("A" & iRowIndex).MergeCells = False) Then objBusLineSheet.Range("A" & iRowIndex).ClearContents 'clean up the white spaces in order to merge the following a few cells End If Else If (iRowIndex >= iPreRowIdx + 1) Then 'objBusLineSheet.Range(objBusLineSheet.Cells("A" & iPreRowIdx), objBusLineSheet.Cells("A" & (iRowIndex - 1))).Merge() Set mergeRan = objBusLineSheet.Range("A" & iPreRowIdx & ":A" & (iRowIndex - 1)) If (mergeRan.MergeCells = False) Then mergeRan.Merge End If With mergeRan '.Merge .WrapText = True '.ShrinkToFit = True 'cannot be true together with WrapText property .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End If objBusLineSheet.Rows(iRowIndex).Borders(xlEdgeTop).LineStyle = xlDouble iPreRowIdx = iRowIndex End If iRowIndex = iRowIndex + 1 Loop If (iRowIndex >= iPreRowIdx + 1) Then Set mergeRan = objBusLineSheet.Range("A" & iPreRowIdx & ":A" & (iRowIndex - 1)) If (mergeRan.MergeCells = False) Then mergeRan.Merge End If With mergeRan .WrapText = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End If 'Format the headline of "Bus Line Details" sheet With objBusLineSheet.Range("A1:J1") .Font.Name = "Arial Unicode MS" .Font.Size = 20 .Font.Bold = True .Font.Italic = True '.Borders(xlEdgeTop).Weight = xlThick 'xlMedium .Borders(xlEdgeBottom).Weight = xlMedium '.Rows(.UsedRange.Rows.Count).Borders(xlEdgeBottom).Weight = xlThick 'xlMedium .Merge .HorizontalAlignment = xlCenter End With 'Format the right border of 1st column With objBusLineSheet.Range(objBusLineSheet.Cells(2, 1), objBusLineSheet.Cells(iRowIndex - 1, 1)) '.Borders(xlEdgeLeft) = xlThick .Borders(xlEdgeRight).Weight = xlMedium End With With objBusLineSheet.Range(objBusLineSheet.Cells(1, 1), objBusLineSheet.Cells(iRowIndex - 1, iMaxColNum)) 'till to the column "J" .Borders(xlEdgeLeft).Weight = xlThick .Borders(xlEdgeRight).Weight = xlThick .Borders(xlEdgeTop).Weight = xlThick .Borders(xlEdgeBottom).Weight = xlThick End With MsgBox ("Over1!") End Sub Private Sub FormatBusStops_Click() Dim iRowIdx As Integer, iColIdx As Integer, iPreRowIdx As Integer Dim iContentStartRow As Integer, iMaxRowCount As Integer Dim objBusStopSheet As Worksheet Dim mergeRan As Range Dim selectedCell As Object Set objBusStopSheet = Worksheets(sBusStopDetailSheet) With objBusStopSheet .Cells.ClearFormats '.Cells.WrapText = True .Cells.Font.Name = "Arial" .Cells.Font.Size = 10 .Cells.Borders.LineStyle = xlLineStyleNone '.Cells.Borders.Weight = xlThin '.Columns(1).Borders(xlEdgeLeft).Weight = xlThick Dim iMaxColNum As Integer, iMaxRowLen As Integer iMaxColNum = 10 Dim i As Integer For i = 1 To iMaxColNum + 1 Step 2 .Columns(i).ColumnWidth = iHeaderColLen .Columns(i + 1).ColumnWidth = iValueColLen Next End With iContentStartRow = 1 iMaxRowCount = 0 iColIdx = 2 Do While (Not isEmptyStr(objBusStopSheet.Cells(iContentStartRow + 1, iColIdx).Value)) With objBusStopSheet.Columns(iColIdx) .ColumnWidth = iHeaderColLen '.Borders(xlEdgeRight).LineStyle = xlDouble .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlEdgeLeft).LineStyle = xlDouble '.Borders(xlEdgeLeft).Weight = xlMedium End With objBusStopSheet.Columns(iColIdx).ColumnWidth = iValueColLen iRowIdx = iContentStartRow + 1 Do While (Not isEmptyStr(objBusStopSheet.Cells(iRowIdx, iColIdx).Value)) '当当前行、当前列的数值不为空时 'With objBusStopSheet.Cells(iRowIdx, iColIdx) ' .HorizontalAlignment = xlLeft 'End With Set selectedCell = objBusStopSheet.Cells(iRowIdx, iColIdx - 1) If (isEmptyStr(selectedCell.Value) And (objBusStopSheet.Range(selectedCell, selectedCell).MergeCells = False)) Then selectedCell.Value = "" End If If (isEmptyStr(objBusStopSheet.Cells(iRowIdx, iColIdx - 1).Value) And _ (Not isEmptyStr(objBusStopSheet.Cells(iRowIdx + 1, iColIdx - 1).Value) Or isEmptyStr(objBusStopSheet.Cells(iRowIdx + 1, iColIdx).Value))) Then '当下一行的站点名不为空，或者下一行线路数据为空时 iPreRowIdx = iRowIdx Do While (isEmptyStr(objBusStopSheet.Cells(iPreRowIdx, iColIdx - 1).Value) And iPreRowIdx > iContentStartRow + 1) iPreRowIdx = iPreRowIdx - 1 Loop Set mergeRan = objBusStopSheet.Range(objBusStopSheet.Cells(iPreRowIdx, iColIdx - 1), objBusStopSheet.Cells(iRowIdx, iColIdx - 1)) If (mergeRan.MergeCells = False) Then mergeRan.Merge End If With mergeRan '.Merge .WrapText = True .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter End With End If iRowIdx = iRowIdx + 1 Loop If (iRowIdx - 1 > iMaxRowCount) Then iMaxRowCount = iRowIdx - 1 End If iColIdx = iColIdx + 2 'move to the next 2 column Loop With objBusStopSheet With .Range(.Cells(2, 1), .Cells(iMaxRowCount, iColIdx - 2)) .Borders(xlInsideHorizontal).LineStyle = xlContinuous .Borders(xlEdgeLeft).Weight = xlThick .Borders(xlEdgeRight).Weight = xlThick .Borders(xlEdgeBottom).Weight = xlThick .WrapText = True .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter End With '.Rows(.UsedRange.Rows.Count).Borders(xlEdgeBottom).Weight = xlThick 'xlMedium With .Range("A1:J1") .Font.Name = "Arial Unicode MS" .Font.Size = 20 .Font.Bold = True .Font.Italic = True '.Borders(xlEdgeTop).Weight = xlThick 'xlMedium '.Borders(xlEdgeBottom).Weight = xlMedium .UnMerge .Borders(xlEdgeLeft).Weight = xlThick .Borders(xlEdgeRight).Weight = xlThick .Borders(xlEdgeTop).Weight = xlThick .Borders(xlEdgeBottom).Weight = xlMedium .Merge End With End With End Sub Private Function isEmptyStr(ByVal oriStr As String) As Boolean Dim result As Boolean result = False oriStr = Replace(oriStr, " ", "") If (oriStr = "") Then result = True End If isEmptyStr = result End Function