VBA：发运后机床售服工作日志信息(涉及引用他表、筛选、引用指定列筛选数据、数据拆分)-CSDN博客

本文链接：https://blog.csdn.net/weixin_44819434/article/details/136623255

领导要求作一张表格，将发运后的机床和售服的日志信息关联起来，方便查询相关信息，以便跟踪。
经过查看发运机床信息表和售服日志信息表，

由于售服日志中，制造编号和出厂编号存在多台在同一行的情况，需要进行拆分。
思路如下：先从发运机床信息表中获取领导要的的数据，然后通过一张中间表，将需要的日志信息存入一张中间表，在中间表中进行拆分，然后将日志与发运机床进行关联。
建的模块如下：
在这里插入图片描述
1、“目录”工作表增加两个按钮，分别用于获取发运机床信息和售服日志

在“thisworkbook”中添加代码如下，用于设置初始状态

Private Sub Workbook_Open()
 ThisWorkbook.Sheets("目录").CommandButton2.Enabled = False
 ThisWorkbook.Sheets("目录").CommandButton1.BackColor = &HE0E0E0
 
End Sub

2、在“目录”页的代码如下。设置编号BH、编号状态BHTYPE和当前年度CURRENTYEAR三个公共参数，用来传递状态

Option Explicit
Public bhtype As Integer
Public bh As String
Public currentyear As Integer

Private Sub CommandButton1_Click()
 Dim ws As Worksheet
 Dim i As Integer

  MainForm.Show
  CommandButton1.BackColor = &HFF00&
  CommandButton2.Enabled = True

End Sub

Private Sub CommandButton2_Click()
If Worksheets("发运机床").Cells(2, 1) = "" Or IsEmpty(Worksheets("发运机床").Cells(2, 1)) Then
    MsgBox "无发运机床数据"
    Exit Sub
End If
   GetData.GetData
   splitdate.splitdate
   quotedate.quotedate
   font.fonts
End Sub

3、设置主界面
在这里插入图片描述
这里主要是考虑领导有时会用机床编号，有时会用出厂编号，甚至查看所有记录。代码如下


Private Sub UserForm_Initialize()
    TextBox2.value = year(Date)
End Sub


Public Sub CommandButton1_Click()

  bh = Me.TextBox1.value
  currentyear = TextBox2.value

    If OptionButton1.value = True Then
      bhtype = 1
    ElseIf OptionButton2.value = True Then
      bhtype = 2
    End If
    If bh = "" Or IsEmpty(bh) Then
      bhtype = 0
    End If
  jichuangdate.GetData currentyear, bhtype, bh
   ThisWorkbook.Worksheets("目录").Cells(1, 1) = bhtype
   ThisWorkbook.Worksheets("目录").Cells(1, 2) = bh
   Unload MainForm
End Sub

Private Sub CommandButton2_Click()
 Me.TextBox1.value = ""
End Sub

Private Sub OptionButton1_Click()
   If OptionButton1.value = True Then
     OptionButton2.value = False 
   End If  
End Sub

Private Sub OptionButton2_Click()
   If OptionButton2.value = True Then
     OptionButton1.value = False
     bhtype = 2
   End If  
End Sub

4、从FTP服务器上获取11#表的发运机床信息。代码在jichuangdate模块中，代码如下

''获取机床信息
Public Sub GetData(ByVal currentyear As Variant, ByVal bhtype As Integer, ByVal bh As Variant)
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim targetWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim myrange As Range
    Dim sheetname As String, path As String
    Dim ws As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim scount As Long, tcount As Long, srow As Long, newcount As Long, startcount As Long
    Dim slastrow As Variant, tlastrow As Variant, colnum As Variant
    Dim rng As Range, rngnew As Variant
    Dim arr, brr, crr

'
   sheetname = "发运机床"

    ' 遍历工作簿中的所有工作表，检查是否存在同名工作表
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = sheetname Then
         i = 1
        End If
    Next ws
    '如果没有则新增
    If i = 0 Then
      Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
      ws.Name = sheetname
    End If


    Worksheets("发运机床").Select
    
    ActiveSheet.Cells(1, 1).CurrentRegion.Clear
    

    tcount = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row '目标表最大行数
    tlastrow = ActiveSheet.Range("A" & tcount).value '目标表最大行A列的值

    '设置目标工作簿、工作表、范围
    Set targetWorkbook = ThisWorkbook
    Set targetWorksheet = ActiveSheet
    Set targetRange = ActiveSheet.Range("A" & tcount)
'

''引用共享中的数据
   path = "\\192.168.100.5\生产中心\生产保障部"
    ''同一个文件夹下的文件就=ThisWorkbook.Path

   f = Dir(path & "\11#生产任务目录.xlsx")
    If f = "" Then
        MsgBox "源文件不存，请查看"
        Exit Sub
    Else
        Set sourceWorkbook = Workbooks.Open(path & "\" & f, Password:="chr", ReadOnly:=True)
    End If
    
      Worksheets("4发运").Select

    Set sourceWorksheet = sourceWorkbook.Worksheets("4发运")


    
'    如果源工作表有过滤，则显示所有数据
    If sourceWorksheet.FilterMode = True Then
     sourceWorksheet.ShowAllData
    End If
    '源数据最大行数及最大行序号值
    scount = sourceWorksheet.Range("A1").End(xlDown).Row
    slastrow = sourceWorksheet.Range("A" & scount).value
    
    
    
    '过滤出出厂日期是2024年的数据
   sourceWorksheet.Range("A1:X" & scount).AutoFilter Field:=21, Criteria2:=Array(0, "12/31/" & currentyear), Operator:=xlFilterValues
   '过滤指定编号的数据
   If bhtype = 1 Then
   sourceWorksheet.Range("A1:X" & scount).AutoFilter Field:=2, Criteria1:=bh
   ElseIf bhtype = 2 Then
   sourceWorksheet.Range("A1:X" & scount).AutoFilter Field:=3, Criteria1:=bh
   End If
   


   '获取过滤后的行数
    i = 0
    For i = 2 To ActiveSheet.UsedRange.Rows.Count
        If Not Rows(i).Hidden Then
        newcount = newcount + 1
        
        End If
    Next i

    Set tarr = targetWorksheet.Range("A1:F" & tcount) '目标表范围


   Set arr = sourceWorksheet.Range("A1:A" & scount).SpecialCells(xlCellTypeVisible, 12)
   Set arr = Union(arr, sourceWorksheet.Range("B1:B" & scount).SpecialCells(xlCellTypeVisible, 12))
   Set arr = Union(arr, sourceWorksheet.Range("C1:C" & scount).SpecialCells(xlCellTypeVisible, 12))
   Set arr = Union(arr, sourceWorksheet.Range("E1:E" & scount).SpecialCells(xlCellTypeVisible, 12))
   Set arr = Union(arr, sourceWorksheet.Range("G1:G" & scount).SpecialCells(xlCellTypeVisible, 12))
   Set arr = Union(arr, sourceWorksheet.Range("U1:U" & scount).SpecialCells(xlCellTypeVisible, 12))
   
    arr.Copy tarr.Range("A1")
       
    
    
  '    关闭源文件
    sourceWorkbook.Close SaveChanges:=False
      
  
    '新增数据加边框
    newcount = ActiveSheet.Range("A1").End(xlDown).Row
    Set myrange = ActiveSheet.Range("A" & tcount + 1 & ":K" & newcount)
    ' 为区域添加边框
    With myrange.Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
    End With
  
    '行高
    Rows(tcount + 1 & ":" & newcount).Select
    Selection.RowHeight = 20

    newcount = ActiveSheet.Range("A1").End(xlDown).Row        
  '排序
   ActiveSheet.Range("A1:K" & newcount).Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes

End Sub

5、在getdate模块中写获取FTP服务器上售服日志数据的代码

''获取售服日志信息

Sub GetData()
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim targetWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim myrange As Range
    Dim sheetname As String, path As String
    Dim ws As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim scount As Long, tcount As Long, srow As Long, newcount As Long, startcount As Long
    Dim slastrow As Variant, tlastrow As Variant, colnum As Variant, BH2 As Variant
    Dim rng As Range, rngnew As Variant
    Dim arr, brr, crr

''从表中引用BH和BHTYPE两个参数
   bhtype = Worksheets("目录").Cells(1, 1)
   bh = Worksheets("目录").Cells(1, 2)
   BH2 = Worksheets("发运机床").Cells(2, 3) '当只查一台时，BH为机床编号时，取其出厂编号
   

   
   sheetname = "售服源记录"

    ' 遍历工作簿中的所有工作表，检查是否存在同名工作表
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = sheetname Then
         i = 1
        End If
    Next ws
    '如果没有则新增
    If i = 0 Then
      Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
      ws.Name = sheetname
    End If

    Worksheets("售服源记录").Select
    Worksheets("售服源记录").Cells.Clear '先清除所有数据
    tcount = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row '目标表最大行数
    tlastrow = ActiveSheet.Range("A" & tcount).value '目标表最大行A列的值
    
    '设置目标工作簿、工作表、范围
    Set targetWorkbook = ThisWorkbook
    Set targetWorksheet = ActiveSheet
    Set targetRange = ActiveSheet.Range("A" & tcount)

   path = "\\192.168.100.5\生产中心\质保中心\最新售后服务部\最新售后服务汇总表\最新售后登记表\最新售服人员出差工作流水台帐"

   f = Dir(path & "\售服人员出差工作流水台帐2024.xlsx")
     ''同一个文件夹下的文件就=ThisWorkbook.Path
    If f = "" Then
        MsgBox "源文件不存，请查看"
        Exit Sub
    Else
        Set sourceWorkbook = Workbooks.Open(path & "\" & f, ReadOnly:=True)
    End If

      Worksheets("sheet1").Select
  
     Set sourceWorksheet = Worksheets("sheet1")
'    如果源工作表有过滤，则显示所有数据
    If sourceWorksheet.FilterMode = True Then
     sourceWorksheet.ShowAllData
    End If
    '如果有标题则删除标题
    If sourceWorksheet.Range("A1") <> "日期" Then
      Rows(1).Delete
    End If
    
    '源数据最大行数及最大行序号值
    scount = sourceWorksheet.Range("A1").End(xlDown).Row
    slastrow = sourceWorksheet.Range("A" & scount).value
    
   '排序
   ActiveSheet.Range("A1:Z" & scount).Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
    
 '过滤出售后类型为“安装调试”"保内维修"“多次安装调试”的数据
   sourceWorksheet.Range("A1:X" & scount).AutoFilter Field:=9, Criteria1:=Array("安装调试", "保内维修", "多次安装调试"), Operator:=xlFilterValues
   
 '过滤指定编号的数据
   If bhtype = 1 Then
   bh = BH2  '用出厂编号来筛选数据
   GoTo AAA:
   ElseIf bhtype = 2 Then
AAA:
   sourceWorksheet.Range("A1:X" & scount).AutoFilter Field:=4, Criteria1:="*" & bh & "*" '出厂编号
   End If
  
     Set rng = sourceWorksheet.UsedRange.SpecialCells(xlCellTypeVisible, 23)
      

    Set tarr = targetWorksheet.Range("A1:F" & tcount) '目标表范围
    
   Set arr = sourceWorksheet.Range("A1:A" & scount).SpecialCells(xlCellTypeVisible, 12)  '日期
   Set arr = Union(arr, sourceWorksheet.Range("B1:B" & scount).SpecialCells(xlCellTypeVisible, 12)) '人员
   Set arr = Union(arr, sourceWorksheet.Range("D1:D" & scount).SpecialCells(xlCellTypeVisible, 12)) '出厂编号
   Set arr = Union(arr, sourceWorksheet.Range("G1:G" & scount).SpecialCells(xlCellTypeVisible, 12)) '工作内容
   Set arr = Union(arr, sourceWorksheet.Range("I1:I" & scount).SpecialCells(xlCellTypeVisible, 12)) '售后类型
   Set arr = Union(arr, sourceWorksheet.Range("L1:L" & scount).SpecialCells(xlCellTypeVisible, 12)) '异常描述果
   Set arr = Union(arr, sourceWorksheet.Range("M1:M" & scount).SpecialCells(xlCellTypeVisible, 12)) '处理结果

    arr.Copy tarr.Range("A1")
       
    
''      关闭源文件
    sourceWorkbook.Close SaveChanges:=False
    
    ''冻结首行并加筛选
    With ActiveWindow
    .SplitColumn = 0
    .SplitRow = 1
    .FreezePanes = True
    End With
    ActiveSheet.Rows(1).AutoFilter
  
   ''后来改的，将人员从B列移到G列，就不用再改splitdate模块了
    Columns("B:B").Select
    Selection.Cut
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight

End Sub

6、对日志信息按出厂编号进行拆分和清洗，并合并相关信息，便于引用，代码在sqplitdate模块中
其中拆分的思路借签了Excel·VBA分列、字符串拆分

''对售服数据进行清洗

Sub splitdate()
    '对选中区域的单元格，内容按指定分隔符拆分，适用整列选中、单列部分选中、单个单元格选中
    Dim rng As Range, delimiter As String, first_row, last_row, first_col, i, j, arr
    Dim rowsum As Long, newcount As Long
    Dim WT As Integer '进度条长度
    
    delimiter = Chr(10)      '分隔符
    Worksheets("售服源记录").Select
    rowsum = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
'    Set rng = Intersect(ActiveSheet.UsedRange, Selection)  'intersect语句避免选择整列造成无用计算
    Set rng = ActiveSheet.Range("B2:B" & rowsum) 'intersect语句避免选择整列造成无用计算
    If rng.Columns.Count > 1 Then Debug.Print "仅支持单列": Exit Sub  '仅支持单列，多列则退出
    first_row = rng.Row     '选中区域开始行号
    last_row = first_row + rng.Rows.Count - 1  '选中区域结束行号
    first_col = rng.Column  '选中区域开始列号
    
Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False   '不显示警告信息

  
    ProgressBar.Show 0 '打开进度条
    WT = ProgressBar.Label1.Width
    ProgressBar.Label1.Width = 0
    ProgressBar.Label1.Caption = "0%"
    ProgressBar.Frame1.Caption = "正在复制数据,请耐心等待......"

    For i = last_row To first_row Step -1   '倒序循环
        '"异常"为空则加上“无异常”,“处理结果”为空则加上“无结果”
        If Range("E" & i) = "" Or IsEmpty(Range("F" & i)) Then
           Range("E" & i) = "无异常"
        End If
        If Range("F" & i) = "" Or IsEmpty(Range("F" & i)) Then
           Range("F" & i) = "无处理结果"
        End If

                  
         '先将需要的内容合并在H列
        Range("H" & i) = "日期：" & WorksheetFunction.text(Range("A" & i), "yyyy/mm/dd") & Chr(10) & Range("C" & i) & Chr(10) & _
                         "售后类型:" & Range("D" & i) & Chr(10) & "异常描述：" & Range("E" & i) & Chr(10) & _
                         "处理结果:" & Range("F" & i)
                             
        '然后拆分合并值（出厂编号）
        If InStr(Cells(i, first_col).value, delimiter) > 0 Then
            arr = Split(Cells(i, first_col).value, delimiter)
            For j = 0 To UBound(arr) - 1  '在当前行后插入、复制本行（插入arr-1行）
                Rows(i + 1).Insert '下面插入空白行
                Rows(i).Copy Range("A" & i + 1) '复制原记录
            Next
            Cells(i, first_col).Resize(UBound(arr) + 1) = WorksheetFunction.Transpose(arr) '将拆分出的值覆盖掉原合并值的单元格         
        End If
    ProgressBar.Label1.Width = (1 - i / last_row) * WT
    ProgressBar.Label1.Caption = Format(1 - i / last_row, "0.0%")
    DoEvents '刷新进度条
    
    Next i
    Unload ProgressBar
    Columns(first_col).AutoFit  '列宽自适应

    ''倒序遍历删除重复行和空行
    ''先按出厂编号和日期排序

    With ActiveSheet
    .Range("H1") = "合并信息" '设“合并信息”在H列
     newcount = .Range("A" & Rows.Count).End(xlUp).Row
     .Range("A2:H" & newcount).Sort key1:=Range("B1"), order1:=xlAscending, key2:=Range("A1"), order2:=xlAscending, Header:=xlYes, MatchCase:=False
    i = 0
    
    
    ProgressBar.Show 0 '打开进度条
    WT = ProgressBar.Label1.Width
    ProgressBar.Label1.Width = 0
    ProgressBar.Label1.Caption = "0%"
    ProgressBar.Frame1.Caption = "正在清理数据,请耐心等待......"
    
    For i = newcount To 2 Step -1
      If .Range("H" & i).value = "" Or IsEmpty(.Range("H" & i)) Then
         .Rows(i).Delete
      End If
      If .Range("H" & i) = .Range("H" & i - 1) Then
         .Range("G" & i - 1).value = .Range("G" & i).value & "、" & .Range("G" & i - 1) '如果合并值相同，则合并人员
         .Rows(i).Delete
      End If
  
    
    ProgressBar.Label1.Width = (1 - i / newcount) * WT
    ProgressBar.Label1.Caption = Format(1 - i / newcount, "0.0%")
    DoEvents '刷新进度条
    
    Next i
    Unload ProgressBar
    
    '合并信息将人员合并进来
    ProgressBar.Show 0 '打开进度条
    WT = ProgressBar.Label1.Width
    ProgressBar.Label1.Width = 0
    ProgressBar.Label1.Caption = "0%"
    ProgressBar.Frame1.Caption = "正在合并数据,请耐心等待......"
    
    j = 0
    newcount = 0
    newcount = .Range("A" & Rows.Count).End(xlUp).Row
    For j = 2 To newcount
          .Range("H" & j) = .Range("H" & j) & Chr(10) & "人员：" & .Range("G" & j)
          
    ProgressBar.Label1.Width = (1 - i / newcount) * WT
    ProgressBar.Label1.Caption = Format(1 - i / newcount, "0.0%")
    DoEvents '刷新进度条
               
    Next j
    Unload ProgressBar
    
   End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True
  
  
End Sub

7、引用日志数据，将发运机床和售日志数据关联起来，代码在quotedate中


''将机床信息与售服信息进行关联
Sub quotedate()

    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim targetWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim scount As Long, tcount As Long, tcol As Long, dicrows As Long, copyrows
    Dim i As Long, j As Long, k As Long, l As Long
    Dim value As Variant
    Dim searchrng As Range, Columnrng As Range, copyrng As Range, cell As Range, Pasterng As Range

  '设置目标工作簿、工作表、范围
    Worksheets("发运机床").Select
    Set targetWorkbook = ThisWorkbook
    Set targetWorksheet = ActiveSheet
    Set targetRange = ActiveSheet.UsedRange
   tcount = targetWorksheet.Range("A1").End(xlDown).Row '目标表行数
   tcol = targetWorksheet.Range("A1").End(xlToRight).Column '目标表列数
   
   Set dic = CreateObject("scripting.dictionary") '建字典
   For i = 2 To tcount
      dic(targetRange.Cells(i, 3).value) = "" '将出厂编号装入字典
   Next
   
''测试字典是否有效
'    Dim kk, vv
'    kk = dic.keys
'    vv = dic.Items
'    For i = 0 To dic.Count - 1
'      Key = kk(i)
'      Value = vv(i)
'      MsgBox Key & Value
'    Next

''字典装入数组
   Dim tarr
   tarr = dic.keys
  
    '设置源工作簿、工作表、范围
'    Worksheets("售服源记录").Select
    Set sourceWorksheet = Worksheets("售服源记录")
    Set sourceRange = Worksheets("售服源记录").UsedRange
    scount = sourceWorksheet.Range("A1").End(xlDown).Row '源表行数
    
    With sourceRange
    
    Set searchrng = .Range("B1:B" & scount) '设置要查询列
    
    For i = 0 To UBound(tarr)
      value = tarr(i)
             
      If WorksheetFunction.CountIf(searchrng, value) > 0 Then '判断值是否在列中，有则过滤出来
       .AutoFilter Field:=2, Criteria1:=value, Operator:=xlAnd
      Set Columnrng = .Columns(8) '定义要复制的列
      Set copyrng = Columnrng.SpecialCells(xlCellTypeVisible)

      
'      ''验证复制出来的数据
'      Columnrng.Copy Worksheets("sheet12").Range("A1")
'      copyrng.Copy Worksheets("sheet12").Range("I1")
      copyrows = copyrng.Count
      
       '找出value值在目标表中的行号
        For j = 1 To tcount
          If targetWorksheet.Range("C" & j) = value Then
             k = j
             GoTo partA
          End If
        Next j
      '将数据复制到目标表指定位置
partA:
        l = 7 '复制的位置从第7列开始
        For Each cell In copyrng
        
         If cell.value <> "合并信息" Then
          targetWorksheet.Cells(k, l) = cell.value
          l = l + 1
         End If
        Next
         
      End If
    Next i

    End With

'删除售服源数据
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("售服源记录").Delete
Application.DisplayAlerts = True

    Worksheets("目录").Cells(1, 1) = ""
    Worksheets("目录").Cells(1, 2) = ""

End Sub

8、最后设置格式，在font模块中


Sub fonts()
Dim datarng As Range, fontrng As Range, cell As Range, col As Range
Dim rowsum As Long, colcount As Long

Worksheets("发运机床").Select

Set datarng = ActiveSheet.Cells(1, 1).CurrentRegion
rowsum = datarng.Rows.Count
colcount = datarng.Columns.Count


' 使用Borders属性来添加边框
With datarng
    .Borders.LineStyle = xlContinuous ' 设置线条样式为连续
    .Borders.Color = RGB(0, 0, 0) ' 设置边框颜色为黑色
    .Borders.Weight = xlThin ' 设置边框粗细为细
End With

Set fontrng = datarng.Range(Cells(2, 7), Cells(rowsum, colcount))

    For Each cell In fontrng
    With cell
        If .Value2 = "" Or IsEmpty(.Value2) Then GoTo part1:
        '文本靠左靠上
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    If (.Value2 <> "" Or Not IsEmpty(.Value2)) _
       And InStr(1, .Value2, "异常描述：无异常") = 0 Then '有异常的增加底色
        .Interior.Pattern = xlSolid
        .Interior.PatternColorIndex = xlAutomatic
        .Interior.Color = RGB(255, 160, 122)
        .Interior.TintAndShade = 0
        .Interior.PatternTintAndShade = 0
        
    End If
[video(video-fNqKVvPr-1710221277304)(type-csdn)(url-https://live.csdn.net/v/embed/369568)(image-https://video-community.csdnimg.cn/vod-84deb4/e0f8b896df7071ee80850764a0ec0102/snapshots/897523f902a14b1d94523dddb830c0e7-00004.jpg?auth_key=4863738544-0-0-445435711d89daf11f605ae0de7f2ed2)(title-发运机床售服日志)]

    End With
part1:
    Next
    
    'A-F列居中，列宽15
    ActiveSheet.Columns("A:F").Select
    Selection.ColumnWidth = 15
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .font.Name = "宋体"
        .font.Size = 12
    End With
     '第一行加筛选,字体加粗，字号16
    ActiveSheet.Range("A1:F1").Select
    Selection.AutoFilter
    With Selection.font
        .Name = "宋体"
        .Size = 16
        .Bold = True
    End With

'  Cells.EntireColumn.AutoFit '所有单元格列宽自动调整
  fontrng.EntireColumn.ColumnWidth = 20 '列宽20
  Cells.EntireRow.AutoFit '所有单元格行高自动调整
  '冻结窗格
    ActiveSheet.Cells(2, 7).Select
    ActiveWindow.FreezePanes = True
End Sub