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

lsc900707 · 发表于 2017-4-11 17:08

wherecoor 发表于 2017-4-11 09:20
汇总内容从f列开始，代码识别a列的文件名

126楼的代码也修改好了：
Sub lsc()
t = Timer
mypath = ThisWorkbook.Path & "\"
myname = Dir(mypath & "*.xls*")
Application.ScreenUpdating = False
crr = [a1].CurrentRegion
ReDim brr(1 To 3000, 1 To 5)
Do While myname <> ""
   For k = 2 To UBound(crr)
         If Split(myname, ".")(0) = Mid(crr(k, 1), 5, 2) And myname <> ThisWorkbook.Name Then
            n = n + 1
            Set sh = GetObject(mypath & myname).Sheets("Sheet1")
            Arr = sh.[a1].CurrentRegion
            Workbooks(myname).Close False
            For i = 2 To UBound(Arr)
               m = m + 1
               For j = 1 To UBound(Arr, 2)
                     brr(m, j) = Arr(i, j)
               Next
            Next
         End If
      Next
      myname = Dir
Loop
Set sh = Nothing
With ActiveSheet
   .[f1:j3000].ClearContents
   .[f1].Resize(1, UBound(Arr, 2)).Value = Arr
   .[f2].Resize(m, UBound(brr, 2)).Value = brr
End With
Application.ScreenUpdating = True
MsgBox "汇总完成！汇总了：" & n & "个工作表；共有：" & m & "行数据 " & vbCr & "用时：" & Format(Timer - t, "0.00") & "秒", vbInformation
End Sub

lsc900707 · 发表于 2017-4-15 08:17

本帖最后由 lsc900707 于 2017-4-15 08:21 编辑

数据查询VBA实现（数据量大情况下实现VLOOKUP函数功能提高速度）
http://club.excelhome.net/thread-1340384-1-1.html
(出处: ExcelHome技术论坛)
Sub lsc()
   Set d = CreateObject("Scripting.Dictionary")
   arr = Sheet1.[a4].CurrentRegion
   For i = 2 To UBound(arr)
      d(arr(i, 1)) = arr(i, 2)
   Next
   brr = ActiveSheet.[a4].CurrentRegion
   For i = 2 To UBound(brr)
      brr(i, 2) = d(brr(i, 1))
   Next
   [a4].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub
另一个网友的提问：
Sub lsc()
Set d = CreateObject("Scripting.Dictionary")
arr = Sheet1.[a4].CurrentRegion
For i = 2 To UBound(arr)
      d(arr(i, 1)) = arr(i, 3)
Next
brr = ActiveSheet.[a4].CurrentRegion
For i = 2 To UBound(brr)
      brr(i, 2) = d(brr(i, 1))
Next
[a4].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

lsc900707 · 发表于 2017-4-15 08:23

满足两条件提取文本
http://club.excelhome.net/thread-1340377-1-1.html
(出处: ExcelHome技术论坛)
Sub lsc()
Set d = CreateObject("Scripting.Dictionary")
Range("a3:a" & [a65536].End(3).Row).ClearContents
Arr = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(Arr)
d(Arr(i, 3)) = Arr(i, 1) & "," & Arr(i, 2)
Next
Brr = Range("a3:c" & [c65536].End(3).Row)
For i = 1 To UBound(Brr)
If d.exists(Brr(i, 3)) Then Cells(i + 2, 1) = Split(d(Brr(i, 3)), ",")(0)
Next
End Sub

lsc900707 · 发表于 2017-4-15 09:19

请问如何实现下面的内容
http://club.excelhome.net/thread-1340353-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
Set d = CreateObject("Scripting.Dictionary")
arr = Sheet2.[a1].CurrentRegion
For i = 1 To UBound(arr)
d(arr(i, 1)) = arr(i, 2)
Next
brr = ActiveSheet.[a1].CurrentRegion
For i = 5 To UBound(brr)
brr(i, 2) = d(brr(i, 1))
Next
[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

复制代码

lsc900707 · 发表于 2017-4-16 11:21

求助自动查找合计行计算当前合计
http://club.excelhome.net/thread-1339974-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
On Error Resume Next
arr = ActiveSheet.Range("A1:G" & Cells(65536, 1).End(3).Row)
For i = 3 To UBound(arr)
If arr(i, 1) <> "合计" And arr(i, 6) <> "" Then
a = a + arr(i, 6)
End If
If arr(i, 1) = "合计" Then
Cells(i, 6) = a
a = 0
End If
Next
End Sub

复制代码

lsc900707 · 发表于 2017-4-20 20:16

Sub 拆分为工作表()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Worksheets
If sh.Name <> "模板" And sh.Name <> "Sheet1" Then sh.Delete
Next
Sheet1.Range("A2:G" & Sheet1.Range("B65536").End(xlUp).Row).Sort Key1:=Range("B1"), Order1:=xlAscending
n = 2
With ThisWorkbook.Sheets("Sheet1")
For Each b In .Range("B2:B" & .Range("B65536").End(xlUp).Row)
u = b.Row
If b <> b.Offset(1, 0) Then
Sheets("模板").Copy After:=Sheets(Worksheets.Count)
.Rows(n & ":" & u).Copy Sheets(Sheets.Count).Range("a4")
Sheets(Sheets.Count).Name = Format(b, "m月d日")
n = u + 1
End If
Next
End With
For Each sh In Sheets
If sh.Name <> "模板" And sh.Name <> "Sheet1" Then
With sh
k = .Range("a65536").End(xlUp).Row
arr = .UsedRange
For i = 4 To UBound(arr)
For j = 5 To UBound(arr, 2)
If IsNumeric(.Cells(i, j)) Then
.Cells(k - 3, j) = Application.Sum(Application.Index(arr, , j))
End If
Next
Next
End With
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

复制代码

请教各位老师，根据总表按日期拆分明细表
http://club.excelhome.net/thread-1340564-1-1.html
(出处: ExcelHome技术论坛)

lsc900707 · 发表于 2017-4-20 20:18

满足条件批量提取的VBA代码
http://club.excelhome.net/thread-1341263-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
Dim brr(1 To 10000, 1 To 10)
Application.ScreenUpdating = False
arr = Sheet3.[b2].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 13) Like "*没到货*" Then
m = m + 1
brr(m, 2) = arr(i, 1): brr(m, 4) = arr(i, 2)
brr(m, 9) = arr(i, 10): brr(m, 10) = arr(i, 3)
End If
Next
If m = 0 Then
MsgBox "没有找到有关信息！"
Else
With ActiveSheet
.[a3].Resize(m, 10) = brr
End With
End If
Application.ScreenUpdating = True
End Sub

复制代码

lsc900707 · 发表于 2017-4-20 20:22

多表汇总
http://club.excelhome.net/thread-1341216-1-1.html
(出处: ExcelHome技术论坛)
Sub lsc()
t = Timer
myPath = ThisWorkbook.Path & "\"
MyName = Dir(myPath & "*.xls*")
Application.ScreenUpdating = False
ReDim brr(1 To 100000, 1 To 3)
Do While MyName <> ""
      If MyName <> ThisWorkbook.Name Then
         n = n + 1
         Set sh = GetObject(myPath & MyName).Sheets("Sheet1")
         Arr = sh.[A1].CurrentRegion
         Workbooks(MyName).Close False
         For i = 2 To UBound(Arr)
            m = m + 1
            For j = 1 To 3
                  brr(m, j) = Arr(i, j)
            Next
         Next
      End If
      MyName = Dir
Loop
Set sh = Nothing
With ActiveSheet
      .Rows("1:30000").ClearContents
      .[A1].Resize(1, UBound(Arr, 2)).Value = Arr
      .[a2].Resize(m, UBound(brr, 2)).Value = brr
End With
Application.ScreenUpdating = True
MsgBox "汇总完成！汇总了：" & n & "个工作表；共有：" & m & "行数据。" & vbCr & "用时：" & Format(Timer - t, "0.00") & "秒", vbInformation
End Sub

lsc900707 · 发表于 2017-4-20 20:24

有3个IF公式求助用VBA代码代替实现
http://club.excelhome.net/thread-1341434-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
Set d = CreateObject("Scripting.Dictionary")
[G2:G1000].ClearContents
Arr = Sheet3.[a1].CurrentRegion
For i = 2 To UBound(Arr)
d(Arr(i, 1)) = Arr(i, 2)
Next
Brr = [a1].CurrentRegion
For i = 2 To UBound(Brr)
If d.exists(Brr(i, 6)) Then Cells(i, 7) = d(Brr(i, 6))
If Cells(i, 1) <> "" Then Cells(i, 2) = "MRWSA" & Format(Cells(i, 1).Row - 1, "0000")
If Cells(i, 9) <> "" Then Cells(i, 13) = Cells(i, 8) / Cells(i, 9)
Next
End Sub

复制代码

凯哥003 · 发表于 2017-4-21 14:58

大哥:你真的好历害

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

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