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

lsc900707 · 发表于 2017-3-19 17:01

代码放模块里，按钮在“合格名单”工作表：
Sub lsc()
Set d = CreateObject("scripting.dictionary")
For Each sht In Sheets
If sht.Name <> ActiveSheet.Name Then
With sht
arr = .UsedRange
For i = 3 To UBound(arr)
For j = 2 To UBound(arr, 2)
If arr(i, j) = "√" Then
d(arr(i, 1)) = d(arr(i, 1)) + 1
End If
Next
Next
End With
End If
Next
t = d.keys
ReDim brr(1 To UBound(t), 1 To 1)
For i = 0 To UBound(t)
If d(t(i)) >= 2 Then
m = m + 1
brr(m, 1) = t(i)
End If
Next
[b3:b1000].ClearContents
[b3].Resize(UBound(brr)) = brr
End Sub

复制代码

来个比较难的给高手练练手
http://club.excelhome.net/thread-1335007-1-1.html
(出处: ExcelHome技术论坛)

lsc900707 · 发表于 2017-3-20 16:55

本帖最后由 lsc900707 于 2017-3-20 23:47 编辑

加入excelhome大家庭1周年纪念：

积分：5648

主题：17

鲜花：978

没有豪言壮语，只有实际行动。勿忘初心，继续前进！

lsc900707 · 发表于 2017-3-20 21:38

本帖最后由 lsc900707 于 2017-3-20 21:40 编辑

根据某列拆分成一个个xls文件，并统计
http://club.excelhome.net/thread-1335252-1-1.html
(出处: ExcelHome技术论坛)

这是拆分成工作表的，拆分不新鲜，主要是统计多列的平均值和求和：
Private Sub CommandButton1_Click()
Dim tim1 As Date, tim2 As Date: tim1 = Timer
Dim arr, d As Object, sht As Worksheet
Set d = CreateObject("scripting.dictionary")
arr = [a1].CurrentRegion
For i = 1 To UBound(arr)
      If Not d.exists(arr(i, 1)) Then
         Set d(arr(i, 1)) = Range("a" & i).Resize(1, 5)
      Else
         Set d(arr(i, 1)) = Union(d(arr(i, 1)), Range("a" & i).Resize(1, 5))
      End If
Next
x = d.keys
For k = 1 To UBound(x)
      Set sht = ActiveWorkbook.Sheets.Add(, after:=ActiveSheet)
      sht.Name = x(k)
      d.items()(k).Copy sht.Range("a" & 2)
      Rows("1:1").Copy sht.[a1]
Next
For Each sht In Sheets
      If sht.Name <> "Sheet1" Then
         With sht
            k = .Cells(.Rows.Count, 1).End(xlUp).Row
            arr = .[a1].CurrentRegion
            For i = 2 To UBound(arr)
               For j = 3 To UBound(arr, 2)
                  If IsNumeric(.Cells(i, j)) Then
                     .Cells(k + 1, 1) = "平均": .Cells(k + 2, 1) = "合计"
                     .Cells(k + 1, j) = Application.Average(Application.Index(arr, , j))
                     .Cells(k + 2, j) = Application.Sum(Cells(i, j).Resize(i - 1, 1))
                  End If
               Next
            Next
         End With
      End If
Next
tim2 = Timer
MsgBox Format(tim2 - tim1, "拆分完成，共耗时：0.00秒"), 64, "时间统计"
End Sub

lsc900707 · 发表于 2017-3-20 21:41

本帖最后由 lsc900707 于 2017-3-20 21:42 编辑

<div class="blockcode"><blockquote>这是另存工作簿的，能保持列宽不变：
Private Sub CommandButton1_Click()
Set rng = Range("a1:e1")
Application.ScreenUpdating = False
arr = Range("a1:e" & Range("a65536").End(xlUp).Row)
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
Set d(arr(i, 1)) = Cells(i, 1).Resize(1, 5)
Else
Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, 5))
End If
Next
k = d.keys: t = d.items
For x = 0 To d.Count - 1
Set wb = Workbooks.Add(xlWBATWorksheet)
With wb.Sheets(1)
rng.Copy .[a1]: t(x).Copy .[A2]
arr = .[a1].CurrentRegion
n = .Cells(65536, 1).End(xlUp).Row
For m = 3 To UBound(arr, 2)
If IsNumeric(.Cells(n, m)) Then
.Cells(n + 1, 1) = "平均": .Cells(n + 2, 1) = "合计"
.Cells(n + 1, m) = Application.Average(Application.Index(arr, , m))
.Cells(n + 2, m) = Application.Sum(Cells(n, m).Resize(n - 1, 1))
.Columns(m).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(m).ColumnWidth
End If
Next
End With
wb.SaveAs Filename:=ThisWorkbook.Path & "" & k(x), FileFormat:=xlExcel8
wb.Close
Next
Application.ScreenUpdating = True
Set rng = Nothing: Set wb = Nothing
MsgBox "完毕"
End Sub

复制代码

lsc900707 · 发表于 2017-3-20 22:03

按条件删除指定列中对应的内容
http://club.excelhome.net/thread-1335248-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
For i = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 7) Like "实习*" Or Cells(i, 8) Like "新聘*" Then
Cells(i, 2) = ""
End If
Next
End Sub

复制代码

lsc900707 · 发表于 2017-3-22 23:46

本帖最后由 lsc900707 于 2017-3-22 23:51 编辑

循环求C列值不为空，就复制改行到"打印损耗表"
http://club.excelhome.net/thread-1335721-1-1.html
(出处: ExcelHome技术论坛)

Sub 复制打印损耗表不为空数据()
[a1:m4].Copy Sheets("打印损耗表").[a1]
r = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 1
arr = Range("a5:m" & r)
ReDim brr(1 To 10000, 1 To 12)
For i = 1 To UBound(arr)
If arr(i, 3) <> "0" And arr(i, 3) <> "" Then
m = m + 1
For j = 1 To 12
brr(m, j) = arr(i, j)
Next
End If
Next
With Sheets("打印损耗表")
.[a5].Resize(m, 12) = brr
.Columns("A:N").ColumnWidth = 6
End With
End Sub

复制代码

lsc900707 · 发表于 2017-3-23 00:34

帮忙修改一下代码，改成可以合并子文件夹里的所有工作簿
http://club.excelhome.net/thread-1335341-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
Dim tim1 As Date, tim2 As Date: tim1 = Timer
Dim mypath, myfile, m, j, wb, arr()
Application.ScreenUpdating = False
Sheet1.UsedRange.Offset(1, 0).ClearContents
mypath = ThisWorkbook.Path & "\数据"
myfile = Dir(mypath, vbDirectory)
Do While myfile <> ""
If myfile <> "." And myfile <> ".." Then
If (GetAttr(mypath & myfile) And vbDirectory) = vbDirectory Then
m = m + 1
ReDim Preserve arr(m)
arr(m) = mypath & myfile & ""
End If
End If
myfile = Dir
Loop
For j = 1 To m
myfile = Dir(arr(j) & "*.xls*")
While myfile <> ""
Set wb = CreateObject(arr(j) & myfile)
With CreateObject(arr(j) & myfile)
k = .Sheets(1).UsedRange.Rows.Count + 3
a = .Sheets(1).Range("A5:G" & k)
s = Split(myfile, ".")(0)
.Close False
End With
With Sheet1
.Range("A" & [b65536].End(3).Row + 1).Resize(UBound(a), UBound(a, 2)) = a
.Range("H" & .[h65536].End(3).Row + 1).Resize(UBound(a)) = s
End With
myfile = Dir()
Wend
Next
Set wb = Nothing
Application.ScreenUpdating = True
tim2 = Timer
MsgBox Format(tim2 - tim1, "合并完成，耗时：0.00秒"), 64, "温馨提示"
End Sub

复制代码

lsc900707 · 发表于 2017-3-23 00:34

本帖最后由 lsc900707 于 2017-3-23 00:36 编辑

楼上的代码怎么又少了两个斜杠，干脆这样贴代码好了：
Sub lsc()
Dim tim1 As Date, tim2 As Date: tim1 = Timer
Dim mypath, myfile, m, j, wb, arr()
Application.ScreenUpdating = False
Sheet1.UsedRange.Offset(1, 0).ClearContents
mypath = ThisWorkbook.Path & "\数据\"
myfile = Dir(mypath, vbDirectory)
Do While myfile <> ""
      If myfile <> "." And myfile <> ".." Then
         If (GetAttr(mypath & myfile) And vbDirectory) = vbDirectory Then
            m = m + 1
            ReDim Preserve arr(m)
            arr(m) = mypath & myfile & "\"
         End If
      End If
      myfile = Dir
Loop
For j = 1 To m
      myfile = Dir(arr(j) & "*.xls*")
      While myfile <> ""
         Set wb = CreateObject(arr(j) & myfile)
         With CreateObject(arr(j) & myfile)
         k = .Sheets(1).UsedRange.Rows.Count + 3
            a = .Sheets(1).Range("A5:G" & k)
            s = Split(myfile, ".")(0)
            .Close False
         End With
         With Sheet1
            .Range("A" & [b65536].End(3).Row + 1).Resize(UBound(a), UBound(a, 2)) = a
            .Range("H" & .[h65536].End(3).Row + 1).Resize(UBound(a)) = s
         End With
         myfile = Dir()
      Wend
Next
Set wb = Nothing
Application.ScreenUpdating = True
tim2 = Timer
MsgBox Format(tim2 - tim1, "合并完成，耗时：0.00秒"), 64, "温馨提示"
End Sub

lsc900707 · 发表于 2017-3-26 15:07

本帖最后由 lsc900707 于 2017-3-26 15:10 编辑

Sub 提取农行记录()
Dim brr(1 To 2000, 1 To 5)
For Each sht In Worksheets(Array("一店", "二店"))
arr = sht.[a1].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 4) = "农行" 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("农行记录")
.Columns("B:C").NumberFormatLocal = "@"
.[a2].Resize(n, UBound(arr, 2)) = brr
End With
End If
End Sub
Sub 提取工行记录()
Dim brr(1 To 2000, 1 To 5)
For Each sht In Worksheets(Array("一店", "二店"))
arr = sht.[a1].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 4) = "工行" 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("工行记录")
.Columns("B:C").NumberFormatLocal = "@"
.[a2].Resize(n, UBound(arr, 2)) = brr
End With
End If
End Sub
Sub 提取现金记录()
Dim brr(1 To 2000, 1 To 5)
For Each sht In Worksheets(Array("一店", "二店"))
arr = sht.[a1].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 4) = "现金" 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("现金记录")
.Columns("B:C").NumberFormatLocal = "@"
.[a2].Resize(n, UBound(arr, 2)) = brr
End With
End If
End Sub

复制代码

为按钮求代码
http://club.excelhome.net/thread-1336366-1-1.html
(出处: ExcelHome技术论坛)

Sub 提取农行记录()
Dim brr(1 To 2000, 1 To 5)
For Each sht In Worksheets(Array("一店", "二店"))
   arr = sht.[a1].CurrentRegion
   For i = 2 To UBound(arr)
         If arr(i, 4) = "农行" 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("农行记录")
         .Columns("B:C").NumberFormatLocal = "@"
         .[a2].Resize(n, UBound(arr, 2)) = brr
      End With
End If
End Sub

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

本帖最后由 lsc900707 于 2017-3-26 21:19 编辑

提取文件夹下面，每个工作簿指定列的内容。
http://club.excelhome.net/thread-1336349-1-1.html
(出处: ExcelHome技术论坛)
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

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

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

评分

评分

评分

评分

最新热点 /1