[已解决]查询并拆分

jordanlive

   要求：输入型号，查询总表中型号相同提取相应的数据，生成新的工作表。请高手帮忙编写下VBA代码，谢谢

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-4-20 17:15

SHEET1中：
Private Sub Worksheet_Activate()
  Dim Arr()
  Dim X%, I%
  Dim Rng As Range
  On Error Resume Next
  With Sheet1.Cells(2, 2).Validation
    .Delete
    Set Rng = Sheet2.Range("J4:V4")
    X = Rng.Columns.Count
    ReDim Arr(1 To X)
    For I = 1 To X
      Arr(I) = Rng.Cells(1, I)
    Next
    .Add Type:=3, AlertStyle:=1, Operator:=1, Formula1:=VBA.Join(Arr, ",")  '来自一维数组
    .ErrorMessage = "输入的数值有误,请重新输入！"
  End With
  Set Rng = Nothing
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Arr(), Brr(1 To 10000, 1 To 9)
  Dim Str$
  Dim X%, Y%, I%, K%
  On Error Resume Next
  If Target.Address = Range("B2").Address Then
    Str = Sheet1.Range("B2").Text
    Arr = Sheet2.Range("A1").CurrentRegion
    Sheet3.Name = Str
    Sheet3.Range("A2:I10000").ClearContents
    K = 1
    For Y = 10 To 22
      For X = 6 To UBound(Arr)
        If Arr(4, Y) = Str And Arr(X, Y) > 0 Then
          Brr(K, 1) = Str
          For I = 2 To 8
            Brr(K, I) = Arr(X, I)
          Next I
          Brr(K, 9) = Arr(X, Y)
          K = K + 1
        End If
      Next X
    Next Y
  End If
  Sheet3.Range("A2").Resize(K, 9) = Brr
End Sub

跳转到最佳答案楼层

jordanlive

第一列加下型号

hasyh2008

这个试试看！！！！！！！！！

hasyh2008

SHEET1中：
Private Sub Worksheet_Activate()
  Dim Arr()
  Dim X%, I%
  Dim Rng As Range
  On Error Resume Next
  With Sheet1.Cells(2, 2).Validation
    .Delete
    Set Rng = Sheet2.Range("J4:V4")
    X = Rng.Columns.Count
    ReDim Arr(1 To X)
    For I = 1 To X
      Arr(I) = Rng.Cells(1, I)
    Next
    .Add Type:=3, AlertStyle:=1, Operator:=1, Formula1:=VBA.Join(Arr, ",")  '来自一维数组
    .ErrorMessage = "输入的数值有误,请重新输入！"
  End With
  Set Rng = Nothing
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Arr(), Brr(1 To 10000, 1 To 9)
  Dim Str$
  Dim X%, Y%, I%, K%
  On Error Resume Next
  If Target.Address = Range("B2").Address Then
    Str = Sheet1.Range("B2").Text
    Arr = Sheet2.Range("A1").CurrentRegion
    Sheet3.Name = Str
    Sheet3.Range("A2:I10000").ClearContents
    K = 1
    For Y = 10 To 22
      For X = 6 To UBound(Arr)
        If Arr(4, Y) = Str And Arr(X, Y) > 0 Then
          Brr(K, 1) = Str
          For I = 2 To 8
            Brr(K, I) = Arr(X, I)
          Next I
          Brr(K, 9) = Arr(X, Y)
          K = K + 1
        End If
      Next X
    Next Y
  End If
  Sheet3.Range("A2").Resize(K, 9) = Brr
End Sub

jordanlive

非常感谢