VBA 根据一组条件从工作簿复制和粘贴数据的函数

Question

手头的任务：我有 2 个表：一个需要用 mastersheet 和 mastersheet 的数据填充。以下示例：

我需要从绿色 sheet 复制数据，并根据行和列中的日期和特定文本，将其粘贴到正确列中的白色 sheet 并跳过不正确的。增量线只是计算主sheet 和证据单元格之间的差异。

直到现在我尝试了多个公式，例如白色日期后的 vlookup，但它只从方法 1 中获取数字，如果我使用类似 =if(and(A2=":\green.xlsx[sheet1]"A2; b2="mastersheet"; C1="method1"), ":\green.xlsx[sheet1]"C2; " "), 和只抓取 method1 数据的 vlookups (但它正确地做到了)

试图在 vba 中编写宏，这是问题之一：returns 运行时错误 52。代码如下：

Sub GrabFillData()
'declaring variables and explaining each one role
Dim path As String
Dim newfo As Workbook 'newfo is the newly opened workbook
Dim newfows As Sheets 'newfows is a speciffied sheet to copy data from



With Application.FileDialog(msoFileDialogOpen)
    .Show
    If .SelectedItems.Count = 1 Then
        path = .SelectedItems(1)
    End If
End With

If path <> "" Then
    Open path For Output As #n      ' runtime error 52
End If

我在使用时遇到同样的错误

Sub GetPath()
Dim path As String

path = InputBox("Enter a file path", "Title Here")
Open path For Output As #1
Close #1
End Sub

另一个问题是我认为我知道如何为复制粘贴操作创造条件，我需要一些帮助。

宏会运行从白sheet.

是否有任何公式可以使这更容易？

Answer 1

如果您可以将白色的列名称 sheet 更改为“method1”、“method2”... 要么如果您可以将绿色 sheet 中的行值更改为“payment1”、“payment2”... 然后你可以使用复杂的 INDEX MATCH 函数。按照下面的link。

https://i.stack.imgur.com/xxACM.png

使用 VBA 您的代码有一些问题。让我们逐一进行。

Dim wb As Workbook, path As String

'You can use FileDialogFilePicker instead
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False    'Forces to choose 1 file.
    If .Show = -1 Then    'Checks if OK button was clicked.
        path = .SelectedItems(1)
    End If
End With

'Use Workbooks.Open method instead of Open.
Set wb = Workbooks.Open(path)

复制粘贴很容易。

Range("A1").Copy
Range("B5").PasteSpecial xlPasteValues 'Paste from A1 to B5

Answer 2

Sub GrabFillData()
'declaring variables and explaining each one role
Dim path As String
Dim newfo As Excel.Workbook 'newfo is the newly opened workbook
Dim Cell_1 As String  ' Cell_1 refer to one cell in workbook
Dim newfows As Integer 'newfows is a speciffied sheet to copy data from
newfows = ActiveSheet.Index


With Application.FileDialog(msoFileDialogOpen)
    .Show
    If .SelectedItems.Count = 1 Then
        path = .SelectedItems(1)
    End If
End With

If path <> "" Then
    'Open path For Output As #n      ' runtime error 52
  Set newfo = Excel.Application.Workbooks.Open(path) ' connect to workbook
  Cell_1 = newfo.Sheets(newfows).Cells(2, 2) ' retrieve value of selected cell to string variable
End If

End Sub

Answer 3

请尝试下一个代码来处理两个 sheet（据我了解）您需要。你没有回答我最后的澄清问题，代码假定最大方法数是 4，并且每个这样的方法都存在唯一的出现。使用数组并主要在内存中工作，代码应该非常快，即使对于大范围也是如此。它将 return 在“H2”中的所有处理范围。如果您喜欢 return，您应该在最后一行代码中将“H2”替换为“A2”：

Sub ProcessPayments()
 Dim shT As Worksheet, lastRT As Long, shM As Worksheet, lastRM As Long, dict As Object
 Dim arr, arrInt, arrT, i As Long, j As Long, k As Long, arrMeth, mtch
 arrMeth = Split("method1,method2,method3,method4", ",")

 Set shT = ActiveSheet 'the white sheet
 lastRT = shT.Range("A" & shT.rows.count).End(xlUp).row  'last row in A:A
 arrT = shT.Range("A2:F" & lastRT).value 'place the range in an array for faster iteration

 Set shM = shT.Next ' use here the master sheet you need
 lastRM = shM.Range("A" & shM.rows.count).End(xlUp).row  'last row in A:A
 arr = shM.Range("A2:C" & lastRM).value 'place the range in an array for faster iteration

 Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary
 For i = 1 To UBound(arr)    'iterate between the array rows and place the necessary values in dictionary
    If Not dict.Exists(arr(i, 1)) Then 'when the dictionary key does not exist, add a dictionary key as the Date value:
        dict.Add arr(i, 1), Array(Array(arr(i, 2), arr(i, 3))) 'place the item as an array of two elements (method and value)
    Else                     'if the key exists, it add another element in the jagged array containing method ad value
        arrInt = dict(arr(i, 1)): ReDim Preserve arrInt(UBound(arrInt) + 1)  'redim the existing array item with one element
        arrInt(UBound(arrInt)) = Array(arr(i, 2), arr(i, 3))                 'place another array of two in the last added element
        dict(arr(i, 1)) = arrInt                                                             'place the intermediary array back to dictionary
    End If
 Next i

 'Put the necessary data in the white sheet fields:
 For i = 1 To UBound(arrT)                      'iterate between the array elements:
    If arrT(i, 2) = "mastersheet" Then          'for the rows having "mastersheet" in the second column:
        For j = 0 To dict.count - 1             'iterate between the dictionary keys:
            If arrT(i, 1) = dict.Keys()(j) Then 'when the dictionary key has been found:
                For k = 0 To UBound(dict.items()(j)) 'Iterate between each array of the jag array item:
                    'match the array first item (method) in arrMeth (to set the column where to place the value):
                    mtch = Application.match(dict.items()(j)(k)(0), arrMeth, 0)
                    arrT(i, mtch + 2) = dict.items()(j)(k)(1)   'place the value in the appropriate column (the second array element)
                Next k
            End If
        Next j
    End If
 Next i
 'Place back the processed array, but not in "A2", only to check if its return is convenient and drop its content in "H2".
 'If convenient, please replace "H2" whith "A2"
shT.Range("H2").Resize(UBound(arrT), UBound(arrT, 2)).value = arrT
End Sub

如果所涉及的两个 sheet 属于同一个工作簿，我无法从您的问题中了解到。上面的代码也适用于来自不同 workbooks/worksheets 的 sheet。您应该注意正确设置 shM。现在是白色之后的下一个sheet...

如果您需要让代码使用对话框打开工作簿，这应该是小菜一碟。您已经收到了这个简单部分的答案，我想...

我尝试对每一行代码进行注释。如果有什么不是很清楚，请不要犹豫，要求澄清。但是经过测试...

VBA 根据一组条件从工作簿复制和粘贴数据的函数

VBA function to copy and paste data from a workbook,based on a set of conditions

excel

vba

excel-formula