VBA

小星光

请教老师问题

3190496160

Sub 导出()
Application.ScreenUpdating = False
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("资料导出表")
    gzb = .[l2]
    gzbb = .[l3]
    If gzb = "" Or gzbb = "" Then MsgBox "请输入导入文件信息！": End
    lj = ThisWorkbook.Path & "\"
    f = Dir(lj & gzbb & ".xls*")
    If f = "" Then
        .Copy
        Set wb = ActiveWorkbook
        With wb.Worksheets(1)
            .Name = gzb
            .Columns("k:l").Delete
            For Each shp In .Shapes
                shp.Delete
            Next shp
        End With
        wb.SaveAs Filename:=lj & gzbb & ".xlsx"
        wb.Close
    Else
        Set wb = Workbooks.Open(lj & f, 0)
        For Each sh In wb.Worksheets
            d(sh.Name) = ""
        Next sh
        If Not d.exists(gzb) Then
            .Copy after:=wb.Worksheets(wb.Worksheets.Count)
            With wb.Worksheets(wb.Worksheets.Count)
                .Name = gzb
                .Columns("k:l").Delete
                For Each shp In .Shapes
                    shp.Delete
                Next shp
            End With
        Else
            wb.Close False
            MsgBox gzb & "已经存在，不能重复导出！": End
        End If
        wb.Close True
    End If
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

结算表导出表.rar (13 KB, 下载次数: 22)

2022-11-26 15:28 上传

点击文件名下载附件

小星光

3190496160 发表于 2022-11-26 15:28

高手！太爽了！非常感谢！

小星光

小星光 发表于 2022-11-26 17:36
高手！太爽了！非常感谢！

老师你好：
我写漏了一句。
根据L3工作簿名称“明细表”及L2工作表名称,将A1至H列的数据导入对应工作表,如果对应的工作簿明细表里面没有相应的工作表名称则自动添加工作表并导入，如果对应的工作簿明细表里面有相应的工作表名称则直接覆盖导入。谢谢你老师！

小星光

小星光 发表于 2022-11-26 18:46
老师你好：
我写漏了一句。
根据L3工作簿名称“明细表”及L2工作表名称,将A1至H列的数据导入对应工作表 ...

老师你好：“如果对应的工作簿明细表里面有相应的工作表名称则直接覆盖导入”这个问题能帮我处理一下吗，谢谢！

小星光

小星光 发表于 2022-11-27 08:28
老师你好：“如果对应的工作簿明细表里面有相应的工作表名称则直接覆盖导入”这个问题能帮我处理一下吗， ...

请大家老师帮帮忙！“如果对应的工作簿明细表里面有相应的工作表名称则直接覆盖导入”这个问题能帮我处理一下吗，谢谢！

gwjkkkkk

Sub TEST()
    Dim strFileName$, strPath$, wkb As Workbook, wks As Worksheet, strName$, shp As Shape
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wks = Sheets(1)
    strName = [L2]
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & [L3] & ".xls"
           Set wkb = Workbooks.Open(strFileName)
           wks.Copy after:=Worksheets(Worksheets.Count)
           If bIsWorksheetExist(strName) Then Worksheets(strName).Delete
           Worksheets(Worksheets.Count).Name = strName
           For Each shp In ActiveSheet.Shapes
              shp.Delete
           Next
           wkb.Close True
    Set wkb = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub
Public Function bIsWorksheetExist(wksName As String) As Boolean
    On Error Resume Next
    bIsWorksheetExist = Sheets(wksName).Name = wksName
End Function

gwjkkkkk

请参考附件。。。

小星光

gwjkkkkk 发表于 2022-11-27 20:14
请参考附件。。。

老师您好：这代码非常好,但我想能不能导出时限制在A至H列。