Question

我多年没有使用VBA，可以提供一些帮助。

我的工作簿上有一张名为＆＃34; Materials＆＃34; ＆安培;另一个名为＆＃34; BoM＆＃34;。我想搜索材料表单列H，如果单元格不等于0或者> 0，选择A，C和H中的单元格，将它们复制并经过Sheet BoM中的单元格B，C和D.我还没有在H列中创建非零值的测试，因为我专注于在CopyToBoM中创建一个循环，但却找不到增加范围值（＆＃34; A5，C5，H5＆＃34; ）

这里的代码基于其他地方找到的代码（链接自丢失）并调用Sub CopyAreas：

Sub CopyToBoM()

  Dim OrgSheet As String
  Dim DestSheet As String
  Dim i As Integer
    OrgSheet = "Materials"
    DestSheet = "BoM"

  Dim RngSource As Range, RngDest As Range

For i = 1 To 5
  Set RngSource = Sheets(OrgSheet).Range("A5, C5, H5")
  Set RngDest = Sheets(DestSheet).Cells(Rows.Count, "B").End(xlUp).Offset(1)
  CopyAreas RngSourceA, RngDestA

Next i

End Sub

Sub CopyAreas(Source As Range, Destination, Optional ValuesAndFormatsOnly As Boolean = True)

Dim i As Long, j As Long, RngDest As Range, IsCopyDown As Boolean

On Error GoTo exit_
If TypeName(Destination) = "Worksheet" Then
    Set RngDest = Destination.Range(Source.Address)
Else
    Set RngDest = Destination
End If
IsCopyDown = Source.Cells.Count > RngDest.Cells.Count
With Source
    For i = 1 To .Areas.Count
        If ValuesAndFormatsOnly Then
            .Areas(i).Copy
            If IsCopyDown Then
                RngDest.Cells(1).Offset(, j).PasteSpecial xlPasteValues  'AndNumberFormats
                'RngDest.Cells(1).Offset(, j).PasteSpecial xlPasteFormats
                j = j + .Areas(i).Rows.Count
            Else
                RngDest.Areas(i).PasteSpecial xlPasteValues 'AndNumberFormats
                'RngDest.Areas(i).PasteSpecial xlPasteFormats
            End If
        Application.CutCopyMode = False
            Else
                If IsCopyDown Then
                    .Areas(i).Copy RngDest.RngDest(1).Offset(j)
                    j = j + .Areas(i).Rows.Count
                Else
                     .Areas(i).Copy RngDest.Areas(i)
                End If
        End If
        Next
End With
exit_:
  If Err Then MsgBox Err.Description, vbCritical, "Error #" & Err.Number
End Sub

新BoM Sub

    Sub CopyToBoM()

      Dim OrgSheet As String
      Dim DestSheet As String
      Dim i As Integer
      Dim Materials As Worksheet

        OrgSheet = "Materials"
        DestSheet = "LMG BoM"

      Dim RngSource As Range, RngDest As Range, RngToCopy As Range

    Sheets(OrgSheet).Activate

      Set RngToCopy = Intersect(Sheets(OrgSheet).Range("A:A,C:C,H:H"),
Sheets(OrgSheet).Range("A5:H33").SpecialCells(xlCellTypeVisible))

        If RngToCopy Is Nothing Then
            MsgBox "Ranges do not intersect"
        Else
            RngToCopy.Select
            With ActiveSheet
                .Range("A5:H33").AutoFilter Field:=8, Criteria1:=">0"
            End With
        End If

      Set RngDest = Sheets(DestSheet).Cells(Rows.Count, "B").End(xlUp).Offset(1)

        CopyAreas RngSource, RngDest

    '    Sheets(DestSheet).Activate
    '    LMG_BoM_Format
    End Sub

找到＆amp;基于Col H> 0中的单元将非连续单元复制到新工作簿

0 个答案: