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

lsc900707 · 发表于 2017-3-26 20:01

本帖最后由 lsc900707 于 2017-3-26 22:43 编辑

Sub lsc()
t = Timer
myPath = ThisWorkbook.Path & ""
MyName = Dir(myPath & "*.xls")
Application.ScreenUpdating = False
ReDim brr(1 To 30000, 1 To 3)
Do While MyName <> ""
If MyName <> ThisWorkbook.Name Then
n = n + 1
Set sh = GetObject(myPath & MyName).Sheets(1)
Arr = sh.[A3].CurrentRegion
Workbooks(MyName).Close False
For i = 1 To UBound(Arr)
m = m + 1
brr(m, 1) = Arr(i, 15): brr(m, 2) = Arr(i, 16): brr(m, 3) = Arr(i, 17)
Next
End If
MyName = Dir
Loop
Set sh = Nothing
With Sheet1
.Rows("1:30000").ClearContents
.Columns(1).NumberFormatLocal = "@"
.[A1].Resize(m, 3).Value = brr
End With
Application.ScreenUpdating = True
MsgBox "汇总完成！汇总了：" & n & "个工作表；共有：" & m & "行数据。" & vbCr & "用时：" & Format(Timer - t, "0.00") & "秒", vbInformation
End Sub

复制代码

jiminyanyan · 发表于 2017-3-26 20:39

lsc900707 发表于 2017-3-26 20:01

这代码里面很乱呢………………。

lsc900707 · 发表于 2017-3-26 21:21

jiminyanyan 发表于 2017-3-26 20:39
这代码里面很乱呢………………。

我一贴上代码就是待审核，没看到呢。谢谢你的提醒！

lsc900707 · 发表于 2017-3-28 21:16

求助~excel工作表内容自动合并
http://club.excelhome.net/thread-1336926-1-1.html
(出处: ExcelHome技术论坛)
多个空行的多表数据合并也可以这样写：

Sub lsc()
Dim brr(1 To 2000, 1 To 16)
bt = Sheets(1).Rows(1)
For Each sht In Worksheets(Array("四期", "尚", "建发"))
arr = sht.[a1].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 1) <> "" Then
n = n + 1
For j = 1 To UBound(arr, 2)
brr(n, j) = arr(i, j)
Next
End If
Next
Next
If n = 0 Then
MsgBox "没有找到有关数据！"
Else
With Sheets("汇总")
.Rows(1) = bt
.Columns("F:F").NumberFormatLocal = "@"
.[a2].Resize(n, UBound(arr, 2)) = brr
End With
End If
End Sub

复制代码

lsc900707 · 发表于 2017-3-29 17:29

费用汇总按月拆分
http://club.excelhome.net/thread-1337096-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
With Sheet1
arr = .UsedRange
For i = 2 To UBound(arr)
s = Month(arr(i, 1))
If Not d.exists(s) Then
Set d(s) = .[a1:h1]
End If
Set d(s) = Union(d(s), .Cells(i, 1).Resize(1, 8))
Next
End With
For Each sht In Worksheets
If sht.Name <> "费用汇总" Then
sht.Delete
End If
Next
For Each c In d.keys
Set sht = Worksheets.Add(after:=Worksheets(Worksheets.Count))
With sht
For j = 1 To UBound(arr, 2)
.Columns(j).ColumnWidth = Sheet1.Columns(j).ColumnWidth
Next
.Name = CStr(c) & "月"
d(c).Copy .[a1]
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

复制代码

lsc900707 · 发表于 2017-3-30 17:59

本帖最后由 lsc900707 于 2017-3-30 18:00 编辑

数据格式问题求助！！！！！！！！！！！！！！
http://club.excelhome.net/thread-1337136-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
Sheet1.UsedRange.Copy
[a1].PasteSpecial Paste:=xlPasteValues
For Each Rng In ActiveSheet.UsedRange
      If IsNumeric(Rng) Then
         Range(Rng.Address) = Rng + ""
      End If
Next
End Sub

lsc900707 · 发表于 2017-3-30 18:02

一个工作簿内多个指定工作表怎么汇总
http://club.excelhome.net/thread-1337386-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
For Each sht In Sheets
If sht.Name <> ActiveSheet.Name And sht.Name Like "单体*" Then
Arr = sht.UsedRange
For i = 6 To UBound(Arr)
d(Arr(i, 1)) = d(Arr(i, 1)) + Arr(i, 2)
Next
End If
Next
[b6].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
Application.ScreenUpdating = True
End Sub

复制代码

lsc900707 · 发表于 2017-4-4 17:35

lsc900707 发表于 2017-3-26 15:07
为按钮求代码
http://club.excelhome.net/thread-1336366-1-1.html
(出处: ExcelHome技术论坛)

根据楼主的实际数据，代码修改如下：

Sub 提取农行数据()
Dim brr(1 To 2000, 1 To 10)
Application.ScreenUpdating = False
[a2:j2000].ClearContents
For Each sht In Worksheets(Array("办公人员TOP", "生产中心办-设备TOP", "仓库TOP", "品质TOP", "织造TOP", "染色TOP", "涂层TOP", "印花TOP"))
arr = sht.[a1].CurrentRegion
For i = 4 To UBound(arr) - 1
If arr(i, 9) = "农行" Then
n = n + 1
brr(n, 1) = n: brr(n, 2) = arr(i, 2): brr(n, 3) = arr(i, 3): brr(n, 4) = arr(i, 4): brr(n, 5) = arr(i, 5)
brr(n, 6) = arr(i, 7): brr(n, 7) = arr(i, 8): brr(n, 8) = arr(i, 9): brr(n, 9) = arr(i, 24): brr(n, 10) = arr(i, 25)
End If
Next
Next
If n = 0 Then
MsgBox "没有找到有关信息！"
Else
With Sheets("农行")
.Columns("F:G").NumberFormatLocal = "@"
.[a2].Resize(n, 10) = brr
End With
End If
Application.ScreenUpdating = False
End Sub

复制代码

lsc900707 · 发表于 2017-4-5 20:33

多条件的高级筛选与汇总代码完善
http://club.excelhome.net/thread-1337759-1-1.html
(出处: ExcelHome技术论坛)

Sub 装配()
Set d = CreateObject("Scripting.Dictionary")
Set dic = CreateObject("Scripting.Dictionary")
myr = Sheets("销售订单明细").Cells(Rows.Count, 2).End(xlUp).Row
arr = Sheets("销售订单明细").Range("a1:l" & myr)
For i = 2 To UBound(arr)
If arr(i, 4) Like "装配*" Then
If Not d.exists(arr(i, 5)) Then
d(arr(i, 5)) = arr(i, 2) & "," & arr(i, 6) & "," & arr(i, 11)
dic(arr(i, 5)) = dic(arr(i, 5)) + Val(arr(i, 9))
End If
End If
Next
Application.DisplayAlerts = False
With Sheets("装配生产主计划")
.[b5].Resize(d.Count) = Application.Transpose(d.keys)
.[c5].Resize(d.Count) = Application.Transpose(d.items)
.[c5].Resize(d.Count).TextToColumns comma:=True
.[f5].Resize(dic.Count) = Application.Transpose(dic.items)
End With
Application.DisplayAlerts = True
Set d = Nothing
End Sub
Sub 仪器()
Set d = CreateObject("Scripting.Dictionary")
Set dic = CreateObject("Scripting.Dictionary")
myr = Sheets("销售订单明细").Cells(Rows.Count, 2).End(xlUp).Row
arr = Sheets("销售订单明细").Range("a1:l" & myr)
For i = 2 To UBound(arr)
If arr(i, 4) Like "仪器*" Then
If Not d.exists(arr(i, 5)) Then
d(arr(i, 5)) = arr(i, 2) & "," & arr(i, 6) & "," & arr(i, 11)
dic(arr(i, 5)) = dic(arr(i, 5)) + Val(arr(i, 9))
End If
End If
Next
Application.DisplayAlerts = False
With Sheets("仪器生产主计划")
.[b5].Resize(d.Count) = Application.Transpose(d.keys)
.[c5].Resize(d.Count) = Application.Transpose(d.items)
.[c5].Resize(d.Count).TextToColumns comma:=True
.[f5].Resize(dic.Count) = Application.Transpose(dic.items)
End With
Application.DisplayAlerts = True
Set d = Nothing
End Sub

复制代码

lsc900707 · 发表于 2017-4-5 20:34

本帖最后由 lsc900707 于 2017-4-5 20:39 编辑
将含有特定字符的行显示为红色
http://club.excelhome.net/thread-1338332-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
arr = ActiveSheet.UsedRange
For i = 3 To UBound(arr)
If arr(i, 4) Like "*中学*" Or arr(i, 4) Like "*小学*" Then
Cells(i, 4).Font.ColorIndex = 3
Else
Cells(i, 4).Font.ColorIndex = 0
End If
Next
End Sub

复制代码

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

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