二师兄

嘿嘿。。。我的方法基本相同  一秒左右一个表，2000户差不多也是三四十分钟吧

我们局这项任务目前就只需要我一个人[67]

二师兄

顺便分享一下代码，欢迎拍砖：
Sub 按钮1_Click()
    Dim i As Variant
    Dim aa As Variant
    Dim bb As Variant
    Dim flag As Byte
   
    i = 2
    Do Until Range("F" & i).Value = ""
        i = i + 1
    Loop
    i = i - 1
   
    Rows("2:" & i).Select
    ActiveWorkbook.Worksheets("汇总表").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("汇总表").Sort.SortFields.Add Key:=Range("F2:F" & i) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("汇总表").Sort
        .SetRange Range("A2:w" & i)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    aa = "[汇总表.xlsm]汇总表!"
    bb = "[调查表.xls]2016!"
    flag = 0
    j = 15
    i = 2
    Do Until Range(aa & "F" & i).Value = ""
        If flag = 0 Then
            Workbooks.Open Filename:=ThisWorkbook.Path & "\调查表.xls"
            Range(bb & "D6").Value = Range(aa & "E" & i).Value      '纳税人名称
            Range(bb & "H6").Value = Range(aa & "F" & i).Value      '纳税人识别号
            Range(bb & "D7").Value = Range(aa & "G" & i).Value      '联系人
            Range(bb & "H7").Value = Range(aa & "H" & i).Value      '联系人电话
            Range(bb & "D8").Value = Range(aa & "I" & i).Value      '主管税局
            Range(bb & "H8").Value = Range(aa & "X" & i).Value      '电子邮箱
            Range(bb & "D9:E9").Value = Range(aa & "J" & i).Text      '注册类型代码
            Range(bb & "D10:E10").Value = Range(aa & "L" & i).Text      '行业代码

            Range(bb & "D11").Value = Int(Range(aa & "N" & i).Value + 0.5)      '营业额
            Range(bb & "H11").Value = Int(Range(aa & "O" & i).Value + 0.5)      '利润
            Range(bb & "D12").Value = Int(Range(aa & "P" & i).Value + 0.5)     '应缴
            Range(bb & "H12").Value = Int(Range(aa & "Q" & i).Value + 0.5)     '实缴
            flag = 1
        End If
        '填减免数
        Range(bb & "B" & j).Value = Range(aa & "R" & i).Value
        Range(bb & "F" & j).Value = Range(aa & "T" & i).Value
        Range(bb & "G" & j).Value = Range(aa & "U" & i).Value
        Range(bb & "H" & j).Value = Range(aa & "V" & i).Value
        Range(bb & "I" & j).Value = Range(aa & "W" & i).Value
        j = j + 1
        
        If Range(aa & "F" & i).Value <> Range(aa & "F" & i + 1).Value Then
            Windows("调查表.xls").Activate
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Range(aa & "D" & i).Value & "\" _
                & Range(aa & "F" & i).Value & ".xls"
            ActiveWindow.Close          '关闭
            flag = 0
            j = 15
        End If
        i = i + 1
    Loop
   
End Sub