Question

下面的代码将为A列中的每个单元格创建一个新工作表。第二个模块会将A列中具有特定值的所有行复制到特定目标。

我创建了此表单，因此每个工单号都有自己的工作表，并将具有该工单号的所有行复制到名为该工单号的工作表上。

问题在于，有604个唯一的工作订单编号，我必须为每个工作订单编辑第二个模块，以使其正常工作。

我是否可以通过某种方式遍历A列中的所有值，然后将其与设置变量进行比较，然后将行复制到具有该工作订单号的工作表中？我不知道如何使目标表成为在A列中找到的新值。

我是VBA的新手，所以这个问题可能没有多大意义。是的，我已经看到了用于在一个模块中基于每个新工作订单创建和命名工作表的代码，但是通常不会编译，因此我将流程分为两个模块。

无论如何，为了更好地理解我的意思：说A列有4个工作订单号为1234的行。我需要宏将1234的所有4行复制到名为1234的工作表中。然后移至下一个工单号。它正在检查工作订单的范围是A2：A39986，但完整范围是A2：F39986。

谢谢您的时间。

Option Explicit

Sub parse_data()
   Dim xRCount As Long
   Dim xSht As Worksheet
   Dim xNSht As Worksheet
   Dim I As Long
   Dim xTRow As Integer
   Dim xCol As New Collection
   Dim xTitle As String
   Dim xSUpdate As Boolean
   Set xSht = ActiveSheet
   On Error Resume Next
   xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
   xTitle = "A60:A604"
   xTRow = xSht.Range(xTitle).Cells(1).Row
   For I = 2 To xRCount
     Call xCol.Add(xSht.Cells(I, 1).Text, xSht.Cells(I, 1).Text)
   Next
   xSUpdate = Application.ScreenUpdating
   Application.ScreenUpdating = False
   For I = 1 To xCol.Count
      Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
      Set xNSht = Nothing
      Set xNSht = Worksheets(CStr(xCol.Item(I)))
      If xNSht Is Nothing Then
         Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
         xNSht.Name = CStr(xCol.Item(I))
      Else
         xNSht.Move , Sheets(Sheets.Count)
      End If
      xSht.Range("A" & xTRow & xRCount).EntireRow.Copy xNSht.Range("A60")
      xNSht.Columns.AutoFit
    Next
    xSht.AutoFilterMode = False
    xSht.Activate
    Application.ScreenUpdating = xSUpdate


End Sub

以及将数据复制到特定目标的模块：

    Sub CopyColumnOver()

    Dim wsSource As Worksheet
    Dim wsDestin As Worksheet
    Dim lngDestinRow As Long
    Dim rngSource As Range
    Dim rngCel As Range

    Set wsSource = Sheets("Sheet1")     'Edit "Sheet1" to your source sheet name
    Set wsDestin = Sheets("11556")

    With wsSource
        'Following line assumes column headers in Source worksheet so starts at row2
        Set rngSource = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
    End With

    For Each rngCel In rngSource
        If rngCel.Value = "11556" Then
            With wsDestin
                'Following line assumes column headers in Destination worksheet
                lngDestinRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
                rngCel.EntireRow.Copy Destination:=wsDestin.Cells(lngDestinRow, "A")
            End With
        End If
    Next rngCel

End Sub

将行范围复制到命名工作表

0 个答案: