VBA如何根据条件复制列，请大家帮忙看看，谢谢！！

13602822168

VBA如何根据条件复制列，请大家帮忙看看，谢谢！！

清风竹-

请看附件。

13602822168

清风竹- 发表于 2024-9-4 15:21
请看附件。

感谢帮助！！！谢谢！！！！！

petergaod

1. Sub m()
   
2.     For i = [JG1].Column To [JI1].Column'自定
   
3.         c = [EJ1].Column + Cells(1, i) - 1
   
4.         Cells(2, c).Resize(Rows.Count - 1).Copy Cells(2, i)
   
5.     Next
   
6. End Sub

复制代码

sero61

水平有限 旨在抛砖引玉，仅供指点
Sub s()
arr = Application.Transpose(Range("ej14").CurrentRegion)
brr = Range("jg1").CurrentRegion
For x = 1 To UBound(brr, 2)
    Range("jf14").Offset(0, x).Resize(UBound(arr, 2), 1) = Application.Transpose(Application.Index(arr, brr(1, x)))
Next
End Sub

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, vResult, i&, j&, n&, r&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    br = [EJ1:JE1].Value
    r = Cells(Rows.Count, "EJ").End(xlUp).Row
    ar = Range("EJ14:JE" & r).Value
    For j = 1 To UBound(br, 2): dic(br(1, j)) = j: Next
   
    br = [JG1:JM1].Value
    ReDim vResult(1 To UBound(ar), 1 To UBound(ar, 2))
    For j = 1 To UBound(br, 2)
        If dic.exists(br(1, j)) Then
            n = dic(br(1, j))
            For i = 1 To UBound(vResult)
                vResult(i, j) = ar(i, n)
            Next i
        End If
    Next j
   
    [JG14].Resize(UBound(vResult), UBound(vResult, 2)) = vResult
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

...............

13602822168

gwjkkkkk 发表于 2024-9-4 19:30
Option Explicit
Sub TEST6()
    Dim ar, br, vResult, i&, j&, n&, r&, dic As Object

向老师学习，谢谢！！！！！！！！！！！！