Question

我是VBA和Macro世界的新手。我正在尝试创建数据收集表。第一部分数据从1个工作簿中收集并放在工作簿主文件中。我想要实现的是我提取的新数据将放在工作簿母版中的上一个条目下面。

Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '
    Sheets("For Coordinator Use").Select
    Range("A2:M41").Select
    Selection.Copy
    Windows("Nimble Schedule Import Template- ops.xlsx").Activate
    Range("A1000").End(xlUp).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:= _
        "=0", Operator:=xlOr, Criteria2:="="
    Application.CutCopyMode = False
    Selection.EntireRow.Delete
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
    Windows("Coverage Request Form (9).xlsx").Activate
    Sheets("Request Form").Select 
End Sub

Answer 1

这取决于你想要怎么做。您是否希望使用数组存储数据然后提取到主电子表格，或者您是否只想使用excels内置函数来复制和粘贴数据，就像您在上面所做的那样。您还可以使用脚本字典来存储数据，有很多方法可以解决您想要采用的路径。如果你想拥有一个高性能的宏，那么我建议不要使用excel的内置函数，因为它们比使用数组慢。

2015-08-20更新我已经使用范围对象进行了复制和粘贴。但是，我发现您希望从列表中删除其他一些值，尽管它们保存在表格中而不是电子表格中。它是否正确？请看一下代码我做了一些评论，要求澄清一下。很抱歉这么长时间我忙于完成工作。

Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '

Dim wb As Workbook, ws As Worksheet, rng As Range
Set wb = ThisWorkbook    'Set up the Excel objects you want to use
Set ws = wb.Worksheets("For Coordinator Use")
Set rng = ws.Range("A2:M41") 'asuming this is not changing
'Sheets("For Coordinator Use").Select 'You do not need to select if you use the objects
'Range("A2:M41").Select 'You do not need to select if you use the objects
'Selection.Copy 'you can also get rid of this if using objects
Dim wbDest As Workbook, wsDest As Worksheet, rngDest As Range
Set wbDest = Application.Workbooks("Nimble Schedule Import Template- ops.xlsx") ' Assuming that it is opened
'Windows("Nimble Schedule Import Template- ops.xlsx").Activate 'dont need to activate anything
Set wsDest = wbDest.Worksheets("Sheet1")
Set rngDest = wsDest.Range("A1:A35000")

''optimize the application
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
''''
'''Find the first empty cell in destRng
'Range("A1000").End(xlUp).Select ' this will select the range that is blank only if it does not have data to begin with
Dim i As Long, j As Long, rngAdd As String 'i is the counter and j stores the row where it is blank
For i = 1 To rngDest.Cells.Count
    If IsEmpty(rngDest.Cells(i, 1).Value) Then
        j = i
        i = rngDest.Cells.Count
    End If
Next i

'reset the rngDest
Set rngDest = Nothing
rngAdd = "A" & j & ":M" & (j + 39)
Set rngDest = wsDest.Range(rngAdd)

'make rngDest = rng.Value since they have the same dimension this works
rngDest = rng.Value 'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
'    :=False, Transpose:=False
'I am not sure what you are trying to acheive here a filter??'ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:= _
'    "=0", Operator:=xlOr, Criteria2:="="
'Application.CutCopyMode = False
'Selection.EntireRow.Delete
'ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
''Looks like you are deleting all with a value of "=0"
'Windows("Coverage Request Form (9).xlsx").Activate
'Sheets("Request Form").Select

'Release Objects
Set rngDest = Nothing
Set wsDest = Nothing
Set wbDest = Nothing
Set rng = Nothing
Set ws = Nothing
Set wb = Nothing

''set excel optimization as normal again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAuto
Application.EnableEvents = True
End Sub

Answer 2

以下是代码的修改和注释副本：

Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '
    Sheets("For Coordinator Use").Select
    Range("A2:M41").Copy 'No need to select then copy, just copy is fine
    Windows("Nimble Schedule Import Template- ops.xlsx").Activate
    'I have offset the last row of data by 1 row below, use rows.count rather than a hard row number. Also no need to select
    Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="=0", Operator:=xlOr, Criteria2:="="
    'I don't know what row is selected here but it was in your code so I left it, also no need for cutcopymode as it will cancel when you delete anyway
    Selection.EntireRow.Delete
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
    Windows("Coverage Request Form (9).xlsx").Activate
    Sheets("Request Form").Select
End Sub

如果您不确定，请阅读评论并提出任何问题。这些变化是因为你已经规定你是新手，我不想让你迷惑，这不是最好的方法，我宁愿用数组设置一些东西而不是复制和粘贴。如果你对这个概念回发感到满意，我会为你修改我的代码。

创建一个在最后一个条目下面插入新数据的宏？

2 个答案: