将工作簿中的命名表转移到另一个文件主工作表,并将数据复制到单个表中

时间:2019-05-17 17:17:41

标签: excel vba

VBA的新手,所以希望我能清楚地解释一下...

我最终将拥有32个不同的日志,这些日志具有名为“ DriverLog”的表。它们全部都将保存在MyDocuments中!!! Transportation_Issues_Log !!!!作为启用宏的文件,然后是同一文件夹中名为“ MasterDriverLog”的单个文件。我需要的是一个宏按钮,它将在32个文档中的每个文档上使用新数据更新“ MasterDriverLog”文件。 D列或索引3(表从B列开始)是一个事件编号,该编号对于每个文档都是唯一的。这个想法是在导出之后,它删除重复项,从而仅导出新的驱动程序事件。

我尝试了一些代码,但是我从其他地方获得的代码仅使用范围行和列。它的想法几乎相同,但是不会删除重复项。我还意识到必须同时打开两个文档……这不是问题,而且我知道可以实现这一目标的宏。

Sub Copy_Paste_Below_Last_Cell()


'Find the last used row in both sheets and copy and paste data below existing data.

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

  'Set variables for copy and destination sheets
  Set wsCopy = Workbooks(sPS).Worksheets(1)
  Set wsDest = Workbooks("MasterDriverLog.xlsm").Worksheets(1)

  '1. Find last used row in the copy range based on data in column A
  lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row

  '2. Find first blank row in the destination range based on data in column A
  'Offset property moves down 1 row
  lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row

  '3. Copy & Paste Data
  wsCopy.Range("A2:D" & lCopyLastRow).Copy _
    wsDest.Range("A" & lDestLastRow)

  'Optional - Select the destination sheet
  wsDest.Activate

顺便说一句,我所指的复制工作簿对象正在调用用于保存文件的模块代码(这是宏所在的位置):

Sub SaveBook()
'----------------------------------------------------
'Save File to Hard Drive
'----------------------------------------------------

    Dim sFile As String
    Dim sPath As String
    Dim sPS As String

    sPS = Application.PathSeparator
    sPath = Environ("UserProfile") & sPS & "Documents" & sPS & "!!!Transportation_Issues_Log!!!" & sPS
    CreateDirectory sPath
    If Len(Dir(sPath, vbDirectory)) = 0 Then Exit Sub   'Couldn't create the path due to invalid or inaccessible location
    sFile = Range("G2").Value & "_DriverLog" & ".xlsm"

    ActiveWorkbook.SaveAs Filename:=sPath & sFile, FileFormat:=52

    MsgBox ("This has been saved as '") & sPath & sFile & ("' in your documents folder.  You may create a shortcut, but please do not move target location of file.")

End Sub

Sub CreateDirectory(ByVal arg_sFolderpath As String)

    If Len(Dir(arg_sFolderpath, vbDirectory)) = 0 Then
        Dim sPS As String
        sPS = Application.PathSeparator

        Dim sBuildPath As String
        Dim vFolder As Variant
        For Each vFolder In Split(arg_sFolderpath, sPS)
            If Len(vFolder) > 0 Then
                If Len(sBuildPath) = 0 Then sBuildPath = vFolder Else sBuildPath = sBuildPath & sPS & vFolder
                If Len(Dir(sBuildPath, vbDirectory)) = 0 Then
                    On Error Resume Next
                    MkDir sBuildPath
                    On Error GoTo 0
                    If Len(Dir(sBuildPath, vbDirectory)) = 0 Then
                        MsgBox "[" & sBuildPath & "] is either invalid or unreachable.", , "Create Directory Error"
                        Exit Sub
                    End If
                End If
            End If
        Next vFolder
    End If

End Sub

0 个答案:

没有答案