Excel，VBA：當1個條件應用於多個范圍時，如何將粘貼數據復制到新工作簿中？

Question

當我談到excel和vba時，我總計n00b。 任何幫助將非常感激。

在Excel中有從a到k的數據。 我正在嘗試：檢查是否E> 2，以便在這種情況下為所有行（列）導出G（x），E（x）和J（x）。

我無法正確選擇，並成功將其與條件連接。 另外，我的粘貼是超級隨機的。 我正在嘗試將其導出到給定的文件名@ place，但還沒有真正走到這一步，因為無法將事件正確導出到同一工作簿中的其他工作表。

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False

Dim Value As Range
Dim Copyarea1 As Range
Dim Copyarea2 As Range
Dim Copyarea3 As Range
Dim Copymaster As Range
Dim Pastesheet As Range

Sheet4.Activate
sheet1.Activate

Set Copyarea1 = sheet1.Range("F2")
Set Copyarea2 = sheet1.Range("H2")
Set Copyarea3 = sheet1.Range("I2")
Set Copymaster = Union(Copyarea1, Copyarea2, Copyarea3)


sheet1.Select
For Each Value In Range(["H2:H2539"])
If Value > 2 Then
Value.Select
Selection.Copy

Else: ActiveCell.Offset(1, 0).Activate
End If
If Value = "" Then Exit Sub

Sheet4.Select
  Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
ActiveCell.Offset(1, 0).Activate
sheet1.Activate

Next
Application.ScreenUpdating = True

End Sub

當我用復印原版替換Value時，我得到了正確的初始選擇，但無法抵消。 出口部分不好 只有要復制的值，單元格才有公式。

Answer 1

此代碼首先計算工作簿Book2.xlsm sheet1行，然后遍歷原始工作簿范圍H2：H2539中的所有單元格。 如果value大於2，則將F，H和I列中該行的值粘貼到工作簿Book2.xlsm sheet1 A，B，C行的第一個空行中。

Private Sub CommandButton1_Click()

Workbooks.Open Filename:="C:\Users\User\Desktop\Book2.xlsm" 'change path to your workbook

Dim sh1 As Worksheet, sh2 As Worksheet

Set sh1 = ThisWorkbook.Sheets("sheet1")
Set sh2 = Workbooks("Book2.xlsm").Sheets("sheet1")

Application.ScreenUpdating = False

'counts rows in sheet2 column A (this is where values are going to be copied)
If IsEmpty(sh2.Range("A1").End(xlDown)) = True Then
    y = 1

Else
    y = sh2.Range("A1", sh2.Range("A1").End(xlDown)).Rows.Count + 1

End If


For i = 2 To 2539 'number of rows in your range (sheet1)

    If sh1.Cells(i, 8) > 2 Then

        sh2.Cells(y, 1) = sh1.Cells(i, 8).Offset(0, -2)
        sh2.Cells(y, 1).Offset(0, 1) = sh1.Cells(i, 8)
        sh2.Cells(y, 1).Offset(0, 2) = sh1.Cells(i, 8).Offset(0, 1)

        y = y + 1

    ElseIf sh1.Cells(i, 8) = "" Then: Exit Sub

    End If

Next i

Application.ScreenUpdating = True

Workbooks("2.xlsm").Close savechanges:=True 'closes your second workbook and save changes

End Sub