VBA根据条件从另一个工作簿复制粘贴

Question

我总共有3个工作簿，分别名为wb1，wb2和wb3。 我编写了一个vba程序，将数据复制并粘贴到启用了宏的工作簿中。 我的问题是要以这种方式优化复制和粘贴，如果wb1中B2：B25列中的数据介于-0.1到0.1之间，则下一个连续的C2：C25列和原始B2：B25值将不会被复制。 复制和粘贴将继续进行，直到选中了AG之前的所有列

同样，该程序还将基于上述条件从wb2＆wb3复制并粘贴。 唯一的区别是粘贴位置分别为A5：AG8和A40：AG43。

在wb1中的示例：

A      B   C        D      F
0.09   1   0.0026   0      -0.17
800    2   0.00457  -0.05  -0.15
1600   3.1 0.00345  0.01   -0.1

该程序会将所有数据从A列复制粘贴到C，但是将D＆F忽略到A13：AG36中的excel宏，这将类似于以下结果。

A      B   C        
0.09   1   0.0026   
800    2   0.00457  
1600   3.1 0.00345 

这将在接下来的连续列中继续进行，直到AG； 如果G2：G25的所有值都在-0.1到0.1之间，则G和H均被省略。

下面的程序仅将数据复制并粘贴到excel宏工作簿中，而无需任何过滤器。 如何以实现上述更改的方式进行制作？

Sub TransferTRA015()


Dim strPath2 As String
Dim strPath3 As String
Dim strPath4 As String
Dim wbkWorkbook1 As Workbook
Dim wbkWorkbook2 As Workbook
Dim wbkWorkbook3 As Workbook
Dim wbkWorkbook4 As Workbook

Application.ScreenUpdating = False


strPath2 = "C:\Users\transducer1.CCS\Desktop\LabVIEW Data\TRA015\TRA015_TEST_Room.xlsx"
strPath3 = "C:\Users\transducer1.CCS\Desktop\LabVIEW Data\TRA015\TRA015_TEST_Cold.xlsx"
strPath4 = "C:\Users\transducer1.CCS\Desktop\LabVIEW Data\TRA015\TRA015_TEST_Hot.xlsx"


Set wbkWorkbook1 = ThisWorkbook '### changed this
Set wbkWorkbook2 = Workbooks.Open(strPath2)
Set wbkWorkbook3 = Workbooks.Open(strPath3)
Set wbkWorkbook4 = Workbooks.Open(strPath4)


'### change the sheet and range to what you need
wbkWorkbook1.Worksheets("RAW DATA").Range("A13:AG36").Value = _
    wbkWorkbook2.Worksheets("sheet1").Range("A2:AG25").Value


wbkWorkbook1.Worksheets("RAW DATA").Range("A5:AG8").Value = _
    wbkWorkbook4.Worksheets("sheet1").Range("A2:AG5").Value

wbkWorkbook1.Worksheets("RAW DATA").Range("A40:AG43").Value = _
    wbkWorkbook3.Worksheets("sheet1").Range("A2:AG5").Value


wbkWorkbook2.Close (True)
wbkWorkbook3.Close (True)
wbkWorkbook4.Close (True)

Application.ScreenUpdating = False

End Sub

Answer 1

这是使用WorksheetFunctions来测试范围是否满足您的条件的两种方法。

VBA WorksheetFunction.Min和WorksheetFunction.Max

With wbkWorkbook1.Worksheets("RAW DATA")

    If WorksheetFunction.Min(.Range("B2:B25")) < -0.1 Or WorksheetFunction.Min(.Range("B2:B25")) < -0.1 Then

    End If

End With

Worksheet.Evaluate求值以返回测试该工作表范围的公式的值。

If wbkWorkbook1.Worksheets("RAW DATA").Evaluate("OR(MIN(B2:B25)>=-0.1,MAX(B2:B25)<=0.1)") Then

End If