如何将复制的值附加到vba中的新工作表

时间:2018-01-09 19:47:50

标签: excel vba excel-vba

我需要创建一个分配了宏的按钮。宏需要从工作表上的某些列获取数据并将它们移动到新的列。每次单击按钮时,此新工作表都应更新,方法是将新值添加到现有工作表中。我目前正在使用此代码:

    Sub Consolidate()
'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)  (updated 4/29/2011)
'Summary:    Merge files in a specific folder into one master sheet (stacked)
'            Moves imported files into another folder
' Edited/altered by me

Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet

'Setup
    Application.ScreenUpdating = False  'speed up macro execution
    Application.EnableEvents = False    'turn off other macros for now
    Application.DisplayAlerts = False   'turn off system messages for now

    Set wsMaster = ThisWorkbook.Sheets("BM Condition")    'sheet report is built into

With wsMaster
    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        .UsedRange.Offset(1).EntireRow.Clear
        NR = 2
    Else
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'appends data to existing data
    End If

'Path and filename (edit this section to suit)
    fPath = "C:\Users\test\Desktop\Test\"            'remember final \ in this string"
    fPathDone = fPath & "Imported\"     'remember final \ in this string
    On Error Resume Next
        MkDir fPathDone                 'creates the completed folder if missing
    On Error GoTo 0
    fName = Dir(fPath & "*.xls*")        'listing of desired files, edit filter as desired

'Import a sheet from found files
    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
            Set wbData = Workbooks.Open(fPath & fName)  'Open file

        'This is the section to customize, replace with your own action code as needed
            LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
            Range("P14:S" & LR).EntireRow.Copy .Range("A" & NR)
            wbData.Close False                                'close file
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  'Next row
            Name fPath & fName As fPathDone & fName           'move file to IMPORTED folder
        End If
        fName = Dir                                       'ready next filename
    Loop
End With

ErrorExit:    'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen
End Sub

这写入一个新的工作簿,这很好,但我不希望原始文件从其在网络中的位置移动到导入文件夹。我还在试验如何实现这一目标。现在我在所需文件的fName = Dir(fPath&amp;“ .xls ”)列表中出错,编辑过滤器作为所需行。我不确定为什么会这样,而且不太确定如何修复它。

0 个答案:

没有答案