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