条件复制

霜雪GILL

手动执行宏，当表2中H1:M1中填上相应的数字后，把表1中相应的左边6例复制到表2的O例开始，谢谢

lsc900707

1. Sub gj23w98()
   
2.     Application.ScreenUpdating = False
   
3.     arr = Sheet1.UsedRange
   
4.     brr = [h1:m1]: [o1].Resize(10, 100) = ""
   
5.     For j = 1 To UBound(brr, 2)
   
6.         For k = 1 To UBound(arr, 2)
   
7.             If brr(1, j) = arr(1, k) Then
   
8.                 Sheet1.Cells(1, k).Offset(, -5).Resize(4, 6).Copy Cells(1, 15 + n)
   
9.                 n = n + 6
   
10.             End If
    
11.         Next
    
12.     Next
    
13.     Application.ScreenUpdating = True
    
14. End Sub

复制代码

lsc900707

代码需要审核，先测试参考附件：

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i
  arr = Sheets("sheet2").[h1:m1].Value
  For i = 1 To UBound(arr, 2)
    Sheets("sheet1").Cells(1, (arr(1, i) - 1) * 6 + 1).Resize(4, 6).Copy Sheets("sheet2").Cells(1, (i - 1) * 6 + 15)
  Next
End Sub

霜雪GILL

lsc900707 发表于 2019-10-7 17:09

您好,麻烦再帮帮我改一下代码,万分感激,谢谢!
表1表2表3为数据, 表4为结果
当表4中H1:M1中填上相应的数字后,在表1表2表3中查找相应的值然后复制左边6例到表4的O例开始,谢谢
(因为数据区的列太多一个表放不下,所以分成三个表)

霜雪GILL

一把小刀闯天下 发表于 2019-10-7 19:04
Option Explicit

Sub test()

您好,麻烦再帮帮我改一下代码,万分感激,谢谢!
表1表2表3为数据, 表4为结果
当表4中H1:M1中填上相应的数字后,在表1表2表3中查找相应的值然后复制左边6例到表4的O例开始,谢谢
(因为数据区的列太多一个表放不下,所以分成三个表)

一把小刀闯天下

霜雪GILL 发表于 2019-10-12 23:09
您好,麻烦再帮帮我改一下代码,万分感激,谢谢!
表1表2表3为数据, 表4为结果
当表4中H1:M1中填上相应的数 ...

Option Explicit

Sub test()
  Dim arr, brr, mark, i, j, k, n, dic
  ReDim arr(1 To 100, 1 To 3 * 20 * 6)
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To 3
    brr = Sheets("sheet" & i).[a1].CurrentRegion.Value
    For j = 1 To UBound(brr, 1)
      For k = 1 To UBound(brr, 2)
        arr(j, k + n) = brr(j, k)
        If Len(arr(1, k + n)) Then dic(arr(1, k + n)) = k + n
      Next
    Next
    n = n + UBound(brr, 2)
  Next
  With Sheets("sheet4")
    mark = .[h1:m1].Value
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(mark, 2) * 6)
    For i = 1 To UBound(mark, 2)
      If dic.exists(mark(1, i)) Then
        n = dic(mark(1, i))
        For j = 1 To UBound(arr, 1)
          For k = n - 5 To n
            brr(j, (i - 1) * 6 + k - (n - 5) + 1) = arr(j, k)
          Next
        Next
      End If
    Next
    .[o1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
  End With
End Sub

霜雪GILL

一把小刀闯天下 发表于 2019-10-13 10:44
Option Explicit

Sub test()

对不起，我都不好意思再要你帮我改了，可是不得不再请求你帮我改改代码了，谢谢!
我把数据分成三排在表1中, 表4为结果
当表4中H1:M1中填上相应的数字后,在表1中的E1：AN1，E10：AN10，E19：AN19中查找相应的值然后复制左边6例到表4的O例开始,谢谢

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, pos(), mark, a, b, m, n
  With Sheets("sheet4")
    mark = .[h1].CurrentRegion
    .[o1].Resize(11, UBound(mark, 2) * 6 * 2).ClearContents
  End With
  With Sheets("sheet1")
    For i = 1 To .Cells(Rows.Count, "j").End(xlUp).Row
      If Len(.Cells(i, "j").Value) Then
        j = j + 1
        ReDim Preserve pos(1 To j)
        pos(j) = i
      End If
    Next
    For i = 1 To UBound(mark, 2)
      a = (mark(1, i) - 1) \ 6: b = mark(1, i) Mod 6
      If b = 0 Then b = 6
      a = pos(a + 1): b = (b - 1) * 6 + 5
      m = .Cells(a + 1, b).End(xlDown).Row
      n = n + 1
      .Cells(a, b).Resize(m - a + 1, 6).Copy Sheets("sheet4").Cells(1, (n - 1) * 6 + 15)
    Next
  End With
End Sub

霜雪GILL

一把小刀闯天下 发表于 2019-10-19 07:32
Option Explicit

Sub test()

如果，数据区 向右边再增加多60列数值 ，应该怎修改代码？谢谢！