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

lsc900707

1. Sub lsc()
   
2. arr = Sheet3.UsedRange
   
3. brr = ActiveSheet.UsedRange
   
4. ReDim crr(1 To 10000, 1 To 5)
   
5. For i = 2 To UBound(arr)
   
6.     For j = 3 To UBound(brr)
   
7.         If [a1] = arr(i, 1) And brr(j, 1) = arr(i, 2) And brr(j, 2) = arr(i, 3) Then
   
8.              m = m + 1
   
9.              crr(m, 1) = arr(i, 4): crr(m, 2) = arr(i, 5): crr(m, 3) = arr(i, 8): crr(m, 4) = arr(i, 6): crr(m, 5) = arr(i, 7)
   
10.         End If
    
11.     Next
    
12. Next
    
13. Range("d3:h" & Cells(Rows.Count, 1).End(3).Row).ClearContents
    
14. [d3].Resize(m, 5) = crr
    
15. End Sub

复制代码

多条件查询匹配功能
http://club.excelhome.net/thread-1338224-1-1.html
(出处: ExcelHome技术论坛)

lsc900707

又一个查询的问题：

1. Sub lsc()
   
2.     Dim brr(1 To 10000, 1 To 12)
   
3.     Application.ScreenUpdating = False
   
4.     For Each sht In Sheets
   
5.         If sht.Name <> "汇总" And sht.Name <> ActiveSheet.Name Then
   
6.              arr = sht.UsedRange
   
7.             
   
8.              For i = 5 To UBound(arr)
   
9.                 If arr(i, 2) = [B44] Then
   
10.                      m = m + 1
    
11.                      For j = 1 To UBound(arr, 2)
    
12.                          brr(m, j) = arr(i, j)
    
13.                      Next
    
14.                  End If
    
15.               Next
    
16.         End If
    
17.     Next
    
18.     If m = 0 Then
    
19.         MsgBox "没有找到有关信息！"
    
20.     Else
    
21.         With ActiveSheet
    
22.             .[a47].Resize(m, UBound(arr, 2)) = brr
    
23.         End With
    
24.     End If
    
25.     Application.ScreenUpdating = True
    
26. End Sub

复制代码

关于提取单元格中前两个字符符合条件的行
http://club.excelhome.net/thread-1338490-1-1.html
(出处: ExcelHome技术论坛)

lsc900707

只要A列单元格不为空值时，A列及后面的列就显示外框线
http://club.excelhome.net/thread-1338656-1-1.html
(出处: ExcelHome技术论坛)

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     a = ActiveSheet.UsedRange.Find(what:="*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
   
3.     ActiveSheet.UsedRange.Borders.LineStyle = xlNone
   
4.     For i = 1 To [a65536].End(3).Row
   
5.         If Cells(i, 1) <> "" Then
   
6.             Cells(i, 1).Resize(1, a).Borders.LineStyle = xlContinuous
   
7.         End If
   
8.     Next
   
9. End Sub

复制代码

lsc900707

关于提取单元格中前两个字符符合条件的行
http://club.excelhome.net/thread-1338490-1-1.html
(出处: ExcelHome技术论坛)

1. <div>Sub lsc()
   
2.     Dim brr(1 To 10000, 1 To 12)
   
3.     Application.ScreenUpdating = False
   
4.     For Each sht In Sheets
   
5.         If sht.Name <> "汇总" And sht.Name <> ActiveSheet.Name Then
   
6.              arr = sht.UsedRange
   
7.             
   
8.              For i = 5 To UBound(arr)
   
9.                 If arr(i, 2) = [B44] Then
   
10.                      m = m + 1
    
11.                      For j = 1 To UBound(arr, 2)
    
12.                          brr(m, j) = arr(i, j)
    
13.                      Next
    
14.                  End If
    
15.               Next
    
16.         End If
    
17.     Next
    
18.     If m = 0 Then
    
19.         MsgBox "没有找到有关信息！"
    
20.     Else
    
21.         With ActiveSheet
    
22.             .[A47:L2000] = ""
    
23.             .[a47].Resize(m, UBound(arr, 2)) = brr
    
24.         End With
    
25.     End If
    
26.     Application.ScreenUpdating = True
    
27. End Sub[code]</div><div>
    
28. </div><div>Sub lee()
    
29.     Set d = CreateObject("Scripting.Dictionary")
    
30.     For Each sht In Sheets
    
31.         If sht.Name <> "汇总" And sht.Name <> ActiveSheet.Name Then
    
32.              arr = sht.UsedRange
    
33.              For i = 5 To UBound(arr)
    
34.                  d(arr(i, 2)) = d(arr(i, 2)) + arr(i, 9)
    
35.              Next
    
36.         End If
    
37.     Next
    
38.     arr = ActiveSheet.UsedRange
    
39.     For i = 3 To UBound(arr)
    
40.         If d.exists(arr(i, 2)) Then
    
41.             arr(i, 3) = d(arr(i, 2))
    
42.         End If
    
43.     Next
    
44.     [C3:C41].ClearContents
    
45.     [c3].CurrentRegion = arr
    
46. End Sub</div>

复制代码

[/code]

lsc900707

为什么不能删除“高一”所有工作表
http://club.excelhome.net/thread-1338992-1-1.html
(出处: ExcelHome技术论坛)

1. Sub lsc()
   
2.     Application.DisplayAlerts = False
   
3.     For i = Sheets.Count To 1 Step -1
   
4.         If Sheets(i).Name Like "高一*" Then
   
5.             Sheets(i).Delete
   
6.         End If
   
7.     Next
   
8.     Application.DisplayAlerts = True
   
9. End Sub

复制代码

lsc900707

满足一个条件则提取对应列的值
http://club.excelhome.net/thread-1338957-1-1.html
(出处: ExcelHome技术论坛)

1. Sub lsc()
   
2.     Range("a5:a" & Cells(Rows.Count, 1).End(3).Row) = ""
   
3.     arr = Sheet4.[A1].CurrentRegion
   
4.     ReDim brr(1 To UBound(arr), 1 To 1)
   
5.     For i = 5 To UBound(arr)
   
6.         If arr(i, 21) > 0 Then k = k + 1: brr(k, 1) = arr(i, 1)
   
7.     Next
   
8.     [A5].Resize(k) = brr
   
9. End Sub

复制代码

lsc900707

多条件求和
http://club.excelhome.net/thread-1338955-1-1.html
(出处: ExcelHome技术论坛)

1. Private Sub CommandButton1_Click()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     arr = Sheets("MCI导出").[a1].CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         s = arr(i, 5) & arr(i, 2)
   
6.         d(s) = d(s) + arr(i, 10)
   
7.     Next
   
8.     brr = [b3].CurrentRegion
   
9.     For i = 2 To UBound(brr, 1)
   
10.         For j = 7 To UBound(brr, 2)
    
11.             brr(i, j) = d(brr(i, 4) & brr(1, j))
    
12.         Next
    
13.     Next
    
14.     [b3].CurrentRegion = brr
    
15. End Sub

复制代码

lsc900707

满足两个条件则提取对应列的值
http://club.excelhome.net/thread-1339038-1-1.html
(出处: ExcelHome技术论坛)

1. Sub lsc()
   
2.     Dim brr(1 To 10000, 1 To 8)
   
3.     arr = Sheet4.UsedRange
   
4.     For i = 5 To UBound(arr)
   
5.         If (arr(i, 2) <> "" And arr(i, 2) >= 7) Or arr(i, 21) > 0 Then
   
6.             k = k + 1
   
7.             brr(k, 1) = arr(i, 1): brr(k, 2) = arr(i, 2): brr(k, 3) = arr(i, 3): brr(k, 4) = arr(i, 9)
   
8.             brr(k, 5) = arr(i, 20): brr(k, 6) = arr(i, 19): brr(k, 7) = arr(i, 19) / arr(i, 20): brr(k, 8) = arr(i, 21)
   
9.             
   
10.         End If
    
11.     Next
    
12.     Range("a5:h" & Cells(Rows.Count, 1).End(3).Row) = ""
    
13.     [a5].Resize(k, 8) = brr
    
14. End Sub

复制代码

lsc900707

根据输入指定日期，将日期上一月入职人员自动生成入职报表
http://club.excelhome.net/thread-1339187-1-1.html
(出处: ExcelHome技术论坛)
根据楼主要求和一指禅62老师的纠错，代码修改如下（特别鸣谢一指禅62老师）

1. <div class="blockcode"><blockquote>Sub lsc()
   
2.     Dim brr(1 To 10000, 1 To 14)
   
3.     arr = Sheet1.Range("a1:ap" & Sheet1.Cells(Rows.Count, 1).End(3).Row)
   
4.     For i = 2 To UBound(arr)
   
5.         If Format(arr(i, 5), "yyyymm") = Format(DateAdd("m", -1, Range("N2")), "yyyymm") Then
   
6.             k = k + 1
   
7.             brr(k, 1) = k: brr(k, 2) = arr(i, 2): brr(k, 3) = arr(i, 3): brr(k, 4) = arr(i, 4)
   
8.             brr(k, 5) = arr(i, 5): brr(k, 6) = arr(i, 16): brr(k, 7) = arr(i, 17): brr(k, 8) = arr(i, 18)
   
9.             brr(k, 9) = arr(i, 19): brr(k, 10) = arr(i, 20): brr(k, 11) = arr(i, 21): brr(k, 12) = arr(i, 37)
   
10.             brr(k, 13) = arr(i, 38): brr(k, 14) = arr(i, 39)
    
11.         End If
    
12.     Next
    
13.     With ActiveSheet
    
14.         .[a4:n1000].Clear
    
15.         .Columns("m").NumberFormatLocal = "@"
    
16.         .[a4].Resize(k, 14) = brr
    
17.     End With
    
18. End Sub

复制代码

wherecoor

lsc900707 发表于 2017-3-23 00:34
帮忙修改一下代码，改成可以合并子文件夹里的所有工作簿
http://club.excelhome.net/thread-1335341-1-1.h ...

我想要提取某一个表格里第一列www-01-05中01-05对应的文件内容怎么编程