[已解决]小问题

果冻的心

复制过去没有自动去掉后面没数值的（附件1）
B3单元格未自动填入站点名（附件2 ）
Option Explicit
Sub 数据导入()
    On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
    Application.ScreenUpdating = False '//关闭屏幕刷新
    Application.DisplayAlerts = False '//关闭系统提示
    Application.EnableEvents = False  '//禁止触发其他事件
    Application.StatusBar = False   '关闭系统状态条
    Application.Interactive = False   '禁用鼠标、键盘，防干扰
    Dim MyFile As Object
    Dim AFileName As Variant
    Dim BFileName As Variant
    Dim AWb As Workbook
    Dim BWb As Workbook
    Dim APath$
    Dim ARc%, BRc%, Rc%, K%, AK%, BK%, AStr$, BStr$
    Dim Tim As Single
    Tim = Timer
    Set MyFile = CreateObject("Scripting.FileSystemObject")
    AFileName = Application.GetOpenFilename("EXCEL文件,*.xls*, 所有文件, *.*", 1, Title:="请选择需要导入的源表格：", MultiSelect:=True)
    '修改文件名称
    For AK = 1 To UBound(AFileName)
        AStr = MyFile.Getfile(AFileName(AK)).Name           '名称
        APath = MyFile.Getfile(AFileName(AK)).ParentFolder  'Path
        If VBA.Left(AStr, 1) <> "A" Then
            Name APath & "\" & AStr As APath & "\A" & AStr
            AFileName(AK) = APath & "\A" & AStr
        End If
    Next AK

    BFileName = Application.GetOpenFilename("EXCEL文件,*.xls*, 所有文件, *.*", 1, Title:="请选择需要导入数据的表格：", MultiSelect:=True)
    For BK = 1 To UBound(BFileName)
        BStr = MyFile.Getfile(BFileName(BK)).Name
        Set BWb = GetObject(BFileName(BK))
        BRc = BWb.Sheets("表三甲").Cells(Rows.Count, 1).End(xlUp).Row

        For AK = 1 To UBound(AFileName)
            AStr = MyFile.Getfile(AFileName(AK)).Name
            If AStr = "A" & BStr Then
                Set AWb = GetObject(AFileName(AK))
                With BWb.Sheets("表三甲")
                    ARc = AWb.Sheets("表三甲").Cells(Rows.Count, 1).End(xlUp).Row
                    Rc = ARc + 3 - BRc
                    If Rc < 0 Then
                        .Rows(7).Resize(0 - Rc).Delete
                    ElseIf Rc > 0 Then
                        .Rows(BRc).Offset(-2 - Rc).Resize(Rc).Insert
                        .Range("H7:I" & ARc).FillDown
                    End If

                    AWb.Sheets("表三甲").Range("A6:D" & ARc - 1).Copy .Range("A6")
                    AWb.Sheets("表三甲").Range("F6:H" & ARc - 1).Copy .Range("E6")

                End With
                With BWb.Sheets("表一工程结算")
                    .Range("B3") = MyFile.getbasename(BFileName(BK))

                End With
                AWb.Close False
                GoTo 100
            End If

100:
        Next AK
        With BWb
          .Windows(1).Visible = True
          .Save
          .Close False
        End With
    Next BK
'恢复文件名
    For AK = 1 To UBound(AFileName)
        AStr = MyFile.Getfile(AFileName(AK)).Name           '名称
        If VBA.Left(AStr, 1) = "A" Then
            Name APath & "\" & AStr As APath & "\" & VBA.Right(AStr, Len(AStr) - 1)
        End If
    Next AK

    With ThisWorkbook
      .Windows(1).Visible = True
      .Save
    End With
'    Application.Quit
    MsgBox Format(Timer - Tim, "0.00")
    Set MyFile = Nothing
    Set AWb = Nothing
    Set BWb = Nothing
    Application.StatusBar = True   '恢复系统状态条
    Application.EnableEvents = True  '//恢复触发其他事件
    Application.ScreenUpdating = True '//恢复屏幕刷新
    Application.DisplayAlerts = True '//恢复系统提示
    Application.Interactive = True    '启用鼠标键盘
End Sub

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-6-8 15:13

Rc = ARc + 3 - BRc
                    If Rc < 0 Then
                        .Rows(7).Resize(0 - Rc).Delete
                    ElseIf Rc > 0 Then
                        .Rows(BRc).Offset(-2 - Rc).Resize(Rc).Insert
                        .Range("H7:I" & ARc).FillDown
                    End If

没什么复杂的，这里就是计算下PLM里的表三甲最后一行的行号，与结算表中的表三甲最后一行行号的差，结算表的行数多就删掉，少就添加。

跳转到最佳答案楼层

hasyh2008

原来的表四材料原来是从预算表中复制过来的，原来的预算表中下面有小计、合计及设计负责人等四行，你再看看后来要导入的表格和原来的预算表样式一不一样？

果冻的心

hasyh2008 发表于 2022-6-7 22:37
原来的表四材料原来是从预算表中复制过来的，原来的预算表中下面有小计、合计及设计负责人等四行，你再看看 ...

表四材料那个搞好啦，就是不知道表三那个空白行怎末不行

hasyh2008

你的结算表中“表三甲“”表格样式也不一样，原来的下面有其中室外部分、合计及工程负责人等三行，后发的只有合计一行。原来的表头是六行，后发的是五行。

果冻的心

hasyh2008 发表于 2022-6-7 23:00
你的结算表中“表三甲“”表格样式也不一样，原来的下面有其中室外部分、合计及工程负责人等三行，后发的只 ...

我应该改那一部分

hasyh2008

把这部分看看

Rc = ARc + 3 - BRc
                    If Rc < 0 Then
                        .Rows(7).Resize(0 - Rc).Delete
                    ElseIf Rc > 0 Then
                        .Rows(BRc).Offset(-2 - Rc).Resize(Rc).Insert
                        .Range("H7:I" & ARc).FillDown
                    End If

果冻的心

hasyh2008 发表于 2022-6-8 07:34
把这部分看看

Rc = ARc + 3 - BRc

太难了，研究研究

果冻的心

网上查了下，也搞不明白，

hasyh2008

Rc = ARc + 3 - BRc
                    If Rc < 0 Then
                        .Rows(7).Resize(0 - Rc).Delete
                    ElseIf Rc > 0 Then
                        .Rows(BRc).Offset(-2 - Rc).Resize(Rc).Insert
                        .Range("H7:I" & ARc).FillDown
                    End If

没什么复杂的，这里就是计算下PLM里的表三甲最后一行的行号，与结算表中的表三甲最后一行行号的差，结算表的行数多就删掉，少就添加。

hasyh2008

简单的做法是把PLM里的表三甲的数据复制到结算表中，再添加室外、合计及工程负责人等内容，然后把多余的行删掉。但你要保留公式，就费点事。