见证成长历程---我的答疑解难代码汇总

lsc900707

djyang 发表于 2017-3-16 08:34
牛逼了大神

你的条件比我优越，通过一年的努力，水平一定比我高的。加油!

cbm

赞勤奋，像你学习。

lsc900707

查询数据
http://club.excelhome.net/thread-1334532-1-1.html
(出处: ExcelHome技术论坛)
代码放模块，按钮在sheet2：
Sub lsc()
Dim Arr, i&, d, Brr
Set d = CreateObject("Scripting.Dictionary")
[d2:d50000].ClearContents
Arr = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(Arr)
    d(Arr(i, 7)) = Arr(i, 4)
Next
Brr = [a1].CurrentRegion
For i = 2 To UBound(Brr)
   If d.exists(Brr(i, 2)) Then Cells(i, 4) = d(Brr(i, 2))
Next
End Sub

lsc900707

cbm 发表于 2017-3-16 09:19
赞勤奋，像你学习。

感谢关注，大家一起努力吧！

bqllwb

好作品，收藏学习

lsc900707

满足条件整列复制
http://club.excelhome.net/thread-1334734-1-1.html
(出处: ExcelHome技术论坛)
Sub lsc()
     For j = 2 To [iv1].End(xlToLeft).Column
          If Month(Cells(1,j)) = 4 Then Columns(j).Copy [i1]
     Next
End Sub

lsc900707

lsc900707 发表于 2017-3-18 18:45
满足条件整列复制
http://club.excelhome.net/thread-1334734-1-1.html
(出处: ExcelHome技术论坛)

1. Sub lsc()
   
2.       For j = 2 To [iv1].End(xlToLeft).Column
   
3.            If Month(Cells(1,j)) = 4 Then Columns(j).Copy [i1]
   
4.       Next
   
5. End Sub

复制代码

lsc900707

提取不重数据（修改原代码）
http://club.excelhome.net/thread-1334920-1-1.html
(

1. Sub tttt()
   
2.     Dim i%, k%, arr, brr, crr
   
3.     Dim d As Object
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheet1.Range("A1:at" & Sheet1.Range("a1048576").End(xlUp).Row)
   
6.     For i = 2 To UBound(arr)
   
7.         d(arr(i, 1) & "-" & arr(i, 2) & "-" & arr(i, 6) & "-" & arr(i, 46)) = ""
   
8.          Next
   
9.     brr = Application.Transpose(d.keys)
   
10.     ReDim crr(1 To UBound(brr), 1 To 4)
    
11.     For k = 1 To d.Count
    
12.         crr(k, 1) = Split(brr(k, 1), "-")(0)
    
13.         crr(k, 2) = Split(brr(k, 1), "-")(1)
    
14.         crr(k, 3) = Split(brr(k, 1), "-")(2)
    
15.         crr(k, 4) = Split(brr(k, 1), "-")(3)
    
16.     Next
    
17.     With Sheet2
    
18.         .Columns(1).NumberFormatLocal = "@"
    
19.         .[a1:d1] = Array("凭证序号", "纳税人名称", "二维表列序号", "行业")
    
20.         .[a2].Resize(UBound(crr), 4) = crr
    
21.     End With
    
22. End Sub

复制代码

出处: ExcelHome技术论坛)

nikonmonarch

很多有用的知识点，谢谢楼主。

nikonmonarch

lsc900707 发表于 2017-1-14 07:56
一个跨表查询的案例：
Sub lsc()
    Dim d, Arr, brr, crr, x, y, i, j

d(Arr(i, 1)) = Array(Arr(i, 2), Arr(i, 3), Arr(i, 4))
    crr(i, j + 1) = d(brr(i, 1))(j)

这种用法要学习，谢谢。