如何将工作簿中按指定表名的工作表分开导出保存和根据地址码提取地址

vayli

第一个问题：
我需要将“导出为新工作薄”表中后面数字名称的表按需要单独保存下来，其中：
“设置”表B7单元格 选择“小学”，后面目录根据公式显示相应报表，如：2106、3112、3113，点“导出报表”，就分别导出“2106”表、“3112”表、“3113”表；选择“幼儿园”，目录就显示：2105、3111，点“导出报表”，就分别导出“2105”表、“3111”表。“导出为新工作薄”表中后面数字名称的表中的数据是公式计算的，导出的表要改为具体的数字，详见导出报表示例。
（点“导出报表”按钮，按表号导出按表号命名的表格）
第二个问题：
“中小学特殊教育学生信息台账”中，“户口所在地”列（I列）我想要I8单元格下面的内容，现在我只写了根据身份证提取出地址码的代码（I7单元格上面显示的内容），如何根据地址码提取详细地址不知道怎么写代码。如果用公式就是：=IFERROR(VLOOKUP(MID(H4,1,2)*1,参数!$A$2:$B$36,2,0),"")&IFERROR(VLOOKUP(MID(H4,1,4)&"00",参数!$C$2:$D$3794,2,0),"")&IFERROR(VLOOKUP(MID(H4,1,6),参数!$C$2:$D$3794,2,0),"")，想把这个改成宏运行代码。

3190496160

Sub 导出为工作簿()
Application.ScreenUpdating = False
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    For Each sh In Sheets
        d(sh.Name) = ""
    Next sh
    With Sheets("设置")
        r = .Cells(Rows.Count, 4).End(xlUp).Row
        If r < 3 Then MsgBox "请先获取列表": End
        ar = .Range("d2:f" & r)
    End With
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            If d.exists(ar(i, 1)) Then
                Sheets(Trim(ar(i, 1))).Copy
                Set wb = ActiveWorkbook
                With wb.Worksheets(1)
                    .Name = Split(.[a2], "：")(1)
                End With
                wb.SaveAs Filename:=ThisWorkbook.Path & "\" & ar(i, 1) & ".xls"
                wb.Close
            End If
        End If
    Next i
Application.ScreenUpdating = True
MsgBox "ok!"
   
End Sub

3190496160

Private Sub Worksheet_Change(ByVal T As Range)
Application.ScreenUpdating = False
If T.Row = 7 And T.Column = 2 Then
    If T.Value = "" Then End
    With Sheets("参数")
         rs = .Cells(Rows.Count, 20).End(xlUp).Row
         ar = .Range("q1:t" & rs)
         If rs < 2 Then End
    End With
    Dim br()
    ReDim br(1 To UBound(ar), 1 To 3)
    xx = Trim(T.Value)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 4)) = xx Then
            n = n + 1
            br(n, 1) = ar(i, 1)
            br(n, 2) = ar(i, 2)
            br(n, 3) = ar(i, 3)
        End If
    Next i
    If n = "" Then End
    With Sheets("设置")
        r = .Cells(Rows.Count, 4).End(xlUp).Row
        .Range("d3:f" & r) = Empty
        .[d3].Resize(n, 3) = br
    End With
End If
Application.ScreenUpdating = True
        
End Sub

3190496160

导出为新工作簿.rar (1.29 MB, 下载次数: 12)

2021-10-26 08:48 上传

点击文件名下载附件

vayli

3190496160 发表于 2021-10-26 08:48

非常感谢老师的回复，我下载了，但好像不能导出

3190496160

导出为新工作簿.rar (1.33 MB, 下载次数: 8)

2021-10-26 11:03 上传

点击文件名下载附件

vayli

3190496160 发表于 2021-10-26 11:03

谢谢！可以导出了 但是数据里面有公式，我想要具体的数值。还有一个问题 导出表的标签名是用“设置”表中目录下面的表号

3190496160

vayli 发表于 2021-10-26 11:21
谢谢！可以导出了 但是数据里面有公式，我想要具体的数值。还有一个问题 导出表的标签名是用“设置”表中 ...

论坛是做义务的，一开始就要把自己的真实意图表述清楚，没有人愿意在一个问题上反复折腾的，除非是有偿

vayli

3190496160 发表于 2021-10-26 11:53
论坛是做义务的，一开始就要把自己的真实意图表述清楚，没有人愿意在一个问题上反复折腾的，除非是有偿

OK ！ 非常感谢

vayli

3190496160 发表于 2021-10-26 11:53
论坛是做义务的，一开始就要把自己的真实意图表述清楚，没有人愿意在一个问题上反复折腾的，除非是有偿

我看了半天 我在问题里说明了要 导出的要改为具体的数字