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

Question

I have a total 3 workbooks named wb1, wb2 and wb3. I've written a vba program to copy and paste the data to the macro enabled workbook. The problem I have is to refine the copy&paste in such a way that if the data in column B2:B25 in wb1 is between -0.1 to 0.1, then the next successive column C2:C25 and the original B2:B25 values will not be copied. The copy&pasting will continue until all the columns up to AG has been checked

Simliarly, the program will also copy&paste from wb2 & wb3 based on the above criteria. The only difference is the paste location which will be A5:AG8 and A40:AG43, respectively.

Example In 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

The program will copy paste all data from column A to C but omits D & F to the excel macro in A13:AG36 which will look like the result below.

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

This will continue for next successive columns until AG; if G2:G25 have all values between -0.1 to 0.1 then both G and H are omitted.

The program below simply copy and pastes the data to the excel macro workbook without any filter. How do I make it in a way that it implements the changes above?

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

Here are two ways to use WorksheetFunctions to test if a range meets your conditions.

VBA WorksheetFunction.Min and 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 to return the value of a formula that tests ranges of that worksheet.

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

End If