[已解决]代码怎么写？

dfsfsa · 发表于 2017-5-15 15:35

本帖最后由 dfsfsa 于 2017-5-16 14:47 编辑

El列到H列有3列数据，依次按顺序写到K列到N列，能不能用数组？
附件：

附件.rar (5.92 KB, 下载次数: 10)

france723 · 发表于 2017-5-15 15:48

这个最佳答案由 france723 给出，感谢 france723 的回答。

单击隐藏图章

Sub aaa()
Dim y, ar, br
y = Range("e65536").End(xlUp).Row
ar = Range("e6:h" & y)
j = 1
ReDim br(1 To UBound(ar), 1 To 4)
For i = UBound(ar) To 1 Step -1
br(j, 1) = ar(i, 1)
br(j, 3) = ar(i, 3)
br(j, 4) = ar(i, 4)
j = j + 1
Next i
Range("k6").Resize(UBound(br), 4) = br
End Sub

复制代码

dfsfsa · 发表于 2017-5-15 17:03

france723 发表于 2017-5-15 15:48

能不能改下循环，如果列数比较多，每列都要赋值，那要写多少列？

france723 · 发表于 2017-5-15 17:12

dfsfsa 发表于 2017-5-15 17:03
能不能改下循环，如果列数比较多，每列都要赋值，那要写多少列？

ar范围手动调控( 代码里e列到h列 ), 剩下不变

Sub aaa()
Dim y, ar, br, i, j, n
y = Range("e65536").End(xlUp).Row
ar = Range("e6:h" & y)
j = 1
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = UBound(ar) To 1 Step -1
For n = 1 To UBound(ar, 2)
br(j, n) = ar(i, n)
Next n
j = j + 1
Next i
Range("k6").Resize(UBound(br), UBound(ar, 2)) = br
End Sub

复制代码

dfsfsa · 发表于 2017-6-16 10:14

Sub Macro1()
Dim i As Long, j As Long, r1 As Long, r2 As Long, wb As Workbook
Application.ScreenUpdating = False
p = ActiveWorkbook.Path & "\"
f = Dir(p & "*a*.xls")
Set wb = GetObject(p & f)
r1 = Range("bc" & Rows.Count).End(xlUp).Row
With wb.Sheets(1)
      r2 = .Range("g" & .Rows.Count).End(xlUp).Row
      For i = 4 To r2
         If Len(.Cells(i, "g")) Then
            a = .Cells(i, "g")
            For j = 5 To r1
                  If Cells(j, "bc") Like "*" & a & "*" Then
                     Cells(j, "bi") = .Cells(i, "d") & "；" & .Cells(i, "o") & "；" & .Cells(i, "p")
                  End If
            Next
         End If
      Next
End With
Application.ScreenUpdating = True
End Sub

Sub Macro2()
Dim arr, brr, crr(), i As Long, j As Long, r1 As Long, r2 As Long, wb As Workbook
Application.ScreenUpdating = False
p = ActiveWorkbook.Path & "\"
f = Dir(p & "*b*.xls")
Set wb = GetObject(p & f)
r1 = Range("bc" & Rows.Count).End(xlUp).Row
arr = Range("bc5:bc" & r1)
ReDim crr(1 To UBound(arr), 1 To 1)
With wb.Sheets(1)
      r2 = .Range("g" & .Rows.Count).End(xlUp).Row
      brr = .Range("a4:p" & r2)
      For i = 1 To UBound(brr)
         If Len(brr(i, 7)) Then
            a = brr(i, 7)
            For j = 1 To UBound(arr)
                  If arr(j, 1) Like "*" & a & "*" Then
                     crr(j, 1) = brr(i, 4) & "；" & brr(i, 15) & "；" & brr(i, 16)
                  End If
            Next
         End If
      Next
End With
Range("bi5").Resize(UBound(arr)) = crr
Application.ScreenUpdating = True
End Sub

dfsfsa · 发表于 2017-6-16 10:17

Sub Macro1()
Dim arr, brr(), crr(), d As Object, i As Long, j As Long, k As Long, m As Long, n As Long
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
d("") = ""
arr = Sheets(1).UsedRange
Sheets(3).Cells.Clear
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For j = 1 To UBound(arr, 2)
      If d.exists(arr(1, j)) Then
         m = m + 1
         For i = 1 To UBound(arr)
            brr(i, m) = arr(i, j)
         Next
      End If
Next
ReDim crr(1 To UBound(brr), 1 To UBound(brr, 2))
For k = 1 To UBound(brr)
      crr(k, 1) = brr(k, 1)
      crr(k, 2) = brr(k, 2)
      crr(k, 3) = brr(k, 7)
      crr(k, 4) = brr(k, 9)
      crr(k, 5) = brr(k, 8)
      crr(k, 6) = brr(k, 10)
      crr(k, 7) = brr(k, 3)
      crr(k, 8) = brr(k, 5)
      crr(k, 9) = brr(k, 4)
      crr(k, 10) = brr(k, 6)
Next
drr = crr
n = 1
For s = UBound(crr) To 2 Step -1
      n = n + 1
      For t = 1 To UBound(crr, 2)
         drr(n, t) = crr(s, t)
      Next
Next
With Sheets(3)
      .Range("a1").Resize(UBound(brr), m) = drr
      .Cells.HorizontalAlignment = xlCenter
      .Cells.EntireColumn.AutoFit
      .Activate
End With
Application.ScreenUpdating = True
End Sub

		自动登录	找回密码
密码			注册