如何从总表中提取符合“报表日期”和“批次”的行到报表中

visionn

报表日期	批次
2022.5.5	rlm1

如何从总表中提取符合“报表日期”和“批次”的行到报表中？已有按表头的顺序复制的代码。


总表：

序号	报表日期	批次	标题3	标题4
1	2022.5.5	rlm1	3-1	4-1
2	2022.5.5	rlm1	3-2	4-2
3	2022.5.5	xaf1	3-3	4-3
4	2022.5.5	xaf1	3-4	4-4
5	2022.5.9	rlm1	3-5	4-5
6	2022.5.9	rlm1	3-6	4-6
7	2022.5.9	rlm1	3-7	4-7

报表：

序号	报表日期	批次	标题4	标题3
1	2022.5.5	rlm1	4-1	3-1
2	2022.5.5	rlm1	4-2	3-2
3	2022.5.5	xaf1	4-3	3-3
4	2022.5.5	xaf1	4-4	3-4
5	2022.5.9	rlm1	4-5	3-5
6	2022.5.9	rlm1	4-6	3-6
7	2022.5.9	rlm1	4-7	3-7

Sub 筛选报表()
  Dim r%, i%
  Dim arr, brr
  Dim d As New Dictionary
  With Worksheets("报表")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    If r > 1 Then
      .Range("a2").Resize(r - 1, c).ClearContents
    End If
    arr = .Range("a1").Resize(1, c)
    For j = 1 To c
      If Len(arr(1, j)) <> 0 Then
        d(arr(1, j)) = j
      End If
    Next
  End With
  With Worksheets("总表")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    arr = .Range("a1").Resize(1, c)
    For j = 1 To c
      If Len(arr(1, j)) <> 0 Then
        If d.Exists(arr(1, j)) Then
          .Cells(2, j).Resize(r - 1, 1).Copy Worksheets("报表").Cells(2, d(arr(1, j)))
        End If
      End If
    Next
  End With
End Sub

按指定条件复制报表.zip (11.19 KB, 下载次数: 6)

2022-5-11 10:46 上传

点击文件名下载附件

hasyh2008

Sub 筛选报表()
  Dim Arr(), Brr(1 To 10000, 1 To 5)
  Dim Dic
  Dim Rc%, K%
  Sheet2.Range("A2:E10000").ClearContents
  Set Dic = CreateObject("scripting.dictionary")
  Arr = Sheet1.Range("A1").CurrentRegion
  Dic(Sheet3.Range("A3") & Sheet3.Range("B3")) = ""
  K = 1
  For Rc = 2 To UBound(Arr)
    If Dic.Exists(Arr(Rc, 2) & Arr(Rc, 3)) Then
      Brr(K, 1) = K: Brr(K, 2) = Arr(Rc, 2): Brr(K, 3) = Arr(Rc, 3)
      Brr(K, 4) = Arr(Rc, 4): Brr(K, 5) = Arr(Rc, 5)
      K = K + 1
    End If
  Next Rc
  Sheet2.Range("A2").Resize(K, 5) = Brr
End Sub

hasyh2008

Sub 筛选报表()
  Dim Arr(), Brr(1 To 10000, 1 To 5)
  Dim Rc%, K%
  Sheet2.Range("A2:E10000").ClearContents
  Arr = Sheet1.Range("A1").CurrentRegion
  K = 1
  For Rc = 2 To UBound(Arr)
    If Arr(Rc, 2) & Arr(Rc, 3) = Sheet3.Range("A3") & Sheet3.Range("B3") Then
      Brr(K, 1) = K: Brr(K, 2) = Arr(Rc, 2): Brr(K, 3) = Arr(Rc, 3)
      Brr(K, 4) = Arr(Rc, 4): Brr(K, 5) = Arr(Rc, 5)
      K = K + 1
    End If
  Next Rc
  Sheet2.Range("A2").Resize(K, 5) = Brr
End Sub

visionn

报表列的顺序和总表不同
原过程可以实现在报表中，按照列的名称把全部总表数据提取到报表，但是不知道如何按照条件获取数据
下面是新的附件，有很多列，列的顺序不同

visionn

hasyh2008 发表于 2022-5-11 14:10
Sub 筛选报表()
  Dim Arr(), Brr(1 To 10000, 1 To 5)
  Dim Rc%, K%

非常感谢，但是有35列，并且列的顺序不同，请老大费心如何修改这个过程

hasyh2008

Sub 筛选报表()
  Dim Arr()
  Dim Rc%, K%, Cl%
  Sheet2.Range("A1").CurrentRegion.ClearContents
  Sheet1.Range("A1:AZ1").Copy Sheet2.Range("A1")
  Sheet2.Range("A1") = "序号"
  Arr = Sheet1.Range("A1").CurrentRegion
  Dim Brr(1 To 10000, 1 To 50)
  K = 1
  For Rc = 2 To UBound(Arr)
    If Arr(Rc, 2) & Arr(Rc, 3) = Sheet3.Range("A3") & Sheet3.Range("B3") Then
      Brr(K, 1) = K
      For Cl = 2 To UBound(Arr, 2)
        Brr(K, Cl) = Arr(Rc, Cl)
      Next Cl
      K = K + 1
    End If
  Next Rc
  Sheet2.Range("A2").Resize(K, UBound(Arr)) = Brr
End Sub

visionn

hasyh2008 发表于 2022-5-12 13:46
Sub 筛选报表()
  Dim Arr()
  Dim Rc%, K%, Cl%

学习了，但是改变了列的顺序，报表的顺序不让改变。

hasyh2008

好变态的表格！！

Sub 筛选报表()
  Dim Arr1, Arr2, Brr, Str$
  Dim Rc%, Cl%, X%, ZY%, BY%, K%
  Arr1 = Sheet1.Range("A1").CurrentRegion
  Arr2 = Application.Transpose(Sheet1.Range("A1:AJ1"))
  Sheet2.Range("A2:AJ10000") = ""
  Brr = Sheet2.Range("B1:AJ1")
  Str = Sheet3.Range("A3") & Sheet3.Range("B3")
  K = 2
  For Rc = 2 To UBound(Arr1)
    If Arr1(Rc, 4) & Arr1(Rc, 2) = Str Then
      For Cl = 1 To UBound(Arr1, 2)
        ReDim Preserve Arr2(1 To 36, 1 To K)
        Arr2(Cl, K) = Arr1(Rc, Cl)
      Next Cl
      K = K + 1
    End If
  Next Rc
  If K = 2 Then Exit Sub
  Arr2 = Application.Transpose(Arr2)
  For BY = 1 To 35
    For ZY = 1 To 35
      If Brr(1, BY) = Arr2(1, ZY) Then
        For X = 1 To K - 1
          Arr2(X, 36) = Arr2(X, BY)
          Arr2(X, BY) = Arr2(X, ZY)
          Arr2(X, ZY) = Arr2(X, 36)
          Arr2(X, 36) = ""
        Next X
      End If
    Next ZY
  Next BY
  Sheet2.Range("B1").Resize(K - 1, 35) = Arr2
  For X = 2 To K - 1
    Sheet2.Cells(X, 1) = X - 1
  Next X
End Sub

visionn

老大太厉害了！非常感谢您的热心帮助！