设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › VBA代码的简化
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2586|回复: 6

[已解决]VBA代码的简化

[复制链接]
发表于 2015-10-23 15:15 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 安全网 于 2015-10-26 16:11 编辑

要求对未完成（1）和未完成（2）表内所使用的VBA代码简化吗，只需要打开数据表一次就可以完成2个表内的数据的VBA
最佳答案
月排行榜 / 总排行榜
grf1973
2015-10-26 13:34
  1. Sub TEST()
  2.     Application.ScreenUpdating = False
  3.     Dim X, Y, M, N, L, ARR, ARR1(1 To 30000, 1 To 23), ARR2(1 To 30000, 1 To 23)
  4.     Dim WB As Workbook
  5.     Set WB = Workbooks.Open(ThisWorkbook.Path & "\数据表.xls", Password:="123456789")
  6.     Y = WB.Sheets(1).Range("D" & Rows.Count).End(xlUp).Row
  7.     ARR = WB.Sheets(1).Range("A3:W" & Y)
  8.     For X = 1 To UBound(ARR, 1)
  9.        If (ARR(X, 16) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 23) = "" And ARR(X, 4) <> "" Then
  10.             M = M + 1
  11.          For Y = 1 To UBound(ARR, 2)
  12.             ARR1(M, Y) = ARR(X, Y)
  13.          Next Y
  14.        End If
  15.       
  16.         If (ARR(X, 15) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 22) = "" And ARR(X, 4) <> "" Then
  17.             N = N + 1
  18.          For Y = 1 To UBound(ARR, 2)
  19.             ARR2(N, Y) = ARR(X, Y)
  20.          Next Y
  21.        End If
  22.     Next X
  23.     WB.Close True
  24.     Set WB = Nothing
  25.    
  26.     With ThisWorkbook
  27.         .Sheets(1).Range("A2:W" & Y).Clear
  28.         If M > 0 Then .Sheets(1).Range("A2").Resize(M, 23) = ARR1
  29.         .Sheets(1).Range("A2:W" & M + 1).Borders.LineStyle = xlContinuous
  30.         
  31.         .Sheets(2).Range("A2:W" & Y).Clear
  32.         If N > 0 Then .Sheets(2).Range("A2").Resize(N, 14) = ARR2
  33.         .Sheets(2).Range("A2:N" & N + 1).Borders.LineStyle = xlContinuous
  34.     End With
  35.     Application.ScreenUpdating = True
  36. End Sub
复制代码

逾期1023.rar

741.47 KB, 下载次数: 20
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
grf1973
发表于 2015-10-23 16:22 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub TEST()
  2.     Application.ScreenUpdating = False
  3.     Dim X, Y, M, L, ARR, ARR1(1 To 30000, 1 To 23)
  4.     Dim WB As Workbook
  5.     Set WB = Workbooks.Open(ThisWorkbook.Path & "\数据表.xls", Password:="123456789")
  6.     Y = WB.Sheets(1).Range("D" & Rows.Count).End(xlUp).Row
  7.     ARR = WB.Sheets(1).Range("A3:W" & Y)
  8.     For X = 1 To UBound(ARR, 1)
  9.        If (ARR(X, 16) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 23) = "" And ARR(X, 4) <> "" Then
  10.             M = M + 1
  11.          For Y = 1 To UBound(ARR, 2)
  12.             ARR1(M, Y) = ARR(X, Y)
  13.          Next Y
  14.        End If
  15.     Next X
  16.     WB.Close True
  17.     Set WB = Nothing
  18.    
  19.     With ThisWorkbook
  20.         .Sheets(1).Range("A2:W" & Y).Clear
  21.         .Sheets(1).Range("A2").Resize(UBound(ARR1), 23) = ARR1
  22.         .Sheets(1).Range("A2:W" & M + 1).Borders.LineStyle = xlContinuous
  23.         
  24.         .Sheets(2).Range("A2:W" & Y).Clear
  25.         .Sheets(2).Range("A2").Resize(UBound(ARR1), 14) = ARR1
  26.         .Sheets(2).Range("A2:N" & M + 1).Borders.LineStyle = xlContinuous
  27.     End With
  28.     Application.ScreenUpdating = True
  29. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-10-23 16:31 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
       If (ARR(X, 16) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 23) = "" And ARR(X, 4) <> "" Then如果每个工作表的这个地方的条件不一样，怎么设置
回复

使用道具 举报

 楼主| 发表于 2015-10-24 09:34 | 显示全部楼层
Sub TEST1()
Application.ScreenUpdating = False
Dim X, Y, M, L, ARR, ARR1(1 To 30000, 1 To 23)
Dim WB As Workbook
Set WB = Workbooks.Open(ThisWorkbook.Path & "\数据表.xls", Password:="123456789")
Y = WB.Sheets(1).Range("D" & Rows.Count).End(xlUp).Row
ARR = WB.Sheets(1).Range("A3:W" & Y)
For X = 1 To UBound(ARR, 1)
   If (ARR(X, 16) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 23) = "" And ARR(X, 4) <> "" Then
        M = M + 1
     For Y = 1 To UBound(ARR, 2)
        ARR1(M, Y) = ARR(X, Y)
     Next Y
   End If
Next X
ThisWorkbook.Sheets(1).Range("A2:W" & Y).Clear
ThisWorkbook.Sheets(1).Range("A2").Resize(UBound(ARR1), 23) = ARR1
WB.Save: WB.Close True
ThisWorkbook.Sheets(1).Range("A2:W" & M + 1).Borders.LineStyle = xlContinuous
Set WB = Nothing
Application.ScreenUpdating = True
End Sub
Sub TEST2()
Application.ScreenUpdating = False
Dim X, Y, M, L, ARR, ARR1(1 To 30000, 1 To 23)
Dim WB As Workbook
Set WB = Workbooks.Open(ThisWorkbook.Path & "\数据表.xls", Password:="123456789")
Y = WB.Sheets(1).Range("D" & Rows.Count).End(xlUp).Row
ARR = WB.Sheets(1).Range("A3:W" & Y)
For X = 1 To UBound(ARR, 1)
   If (ARR(X, 15) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 23) = "" And ARR(X, 4) <> "" Then
        M = M + 1
     For Y = 1 To UBound(ARR, 2)
        ARR1(M, Y) = ARR(X, Y)
     Next Y
   End If
Next X
ThisWorkbook.Sheets(2).Range("A2:W" & Y).Clear
ThisWorkbook.Sheets(2).Range("A2").Resize(UBound(ARR1), 14) = ARR1
WB.Save: WB.Close True
ThisWorkbook.Sheets(2).Range("A2:N" & M + 1).Borders.LineStyle = xlContinuous
Set WB = Nothing
Application.ScreenUpdating = True
End Sub比如这个代码怎么简化
回复

使用道具 举报

 楼主| 发表于 2015-10-24 14:02 | 显示全部楼层
请高手帮忙看看
回复

使用道具 举报

 楼主| 发表于 2015-10-25 14:22 | 显示全部楼层
安全网 发表于 2015-10-24 09:34
Sub TEST1()
Application.ScreenUpdating = False
Dim X, Y, M, L, ARR, ARR1(1 To 30000, 1 To 23)

此样的代码有高手帮忙简化么？
回复

使用道具 举报

grf1973
发表于 2015-10-26 13:34 | 显示全部楼层    本楼为最佳答案   
  1. Sub TEST()
  2.     Application.ScreenUpdating = False
  3.     Dim X, Y, M, N, L, ARR, ARR1(1 To 30000, 1 To 23), ARR2(1 To 30000, 1 To 23)
  4.     Dim WB As Workbook
  5.     Set WB = Workbooks.Open(ThisWorkbook.Path & "\数据表.xls", Password:="123456789")
  6.     Y = WB.Sheets(1).Range("D" & Rows.Count).End(xlUp).Row
  7.     ARR = WB.Sheets(1).Range("A3:W" & Y)
  8.     For X = 1 To UBound(ARR, 1)
  9.        If (ARR(X, 16) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 23) = "" And ARR(X, 4) <> "" Then
  10.             M = M + 1
  11.          For Y = 1 To UBound(ARR, 2)
  12.             ARR1(M, Y) = ARR(X, Y)
  13.          Next Y
  14.        End If
  15.       
  16.         If (ARR(X, 15) = "" And 3 <= Now - ARR(X, 14)) And ARR(X, 22) = "" And ARR(X, 4) <> "" Then
  17.             N = N + 1
  18.          For Y = 1 To UBound(ARR, 2)
  19.             ARR2(N, Y) = ARR(X, Y)
  20.          Next Y
  21.        End If
  22.     Next X
  23.     WB.Close True
  24.     Set WB = Nothing
  25.    
  26.     With ThisWorkbook
  27.         .Sheets(1).Range("A2:W" & Y).Clear
  28.         If M > 0 Then .Sheets(1).Range("A2").Resize(M, 23) = ARR1
  29.         .Sheets(1).Range("A2:W" & M + 1).Borders.LineStyle = xlContinuous
  30.         
  31.         .Sheets(2).Range("A2:W" & Y).Clear
  32.         If N > 0 Then .Sheets(2).Range("A2").Resize(N, 14) = ARR2
  33.         .Sheets(2).Range("A2:N" & N + 1).Borders.LineStyle = xlContinuous
  34.     End With
  35.     Application.ScreenUpdating = True
  36. End Sub
复制代码
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-18 16:22 , Processed in 0.303655 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表