Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2236|回复: 3

[已解决]遍历多个工作表的VBA代码修改

[复制链接]
发表于 2017-9-21 10:23 | 显示全部楼层 |阅读模式
本帖最后由 网络人 于 2017-9-25 17:47 编辑

Sub 正单()
    Application.ScreenUpdating = False
    Dim x, y, m, n, o, p, q, r, s, t, arr, ARR1(1 To 30000, 1 To 39), ARR2(1 To 30000, 1 To 39), ARR3(1 To 30000, 1 To 39), ARR4(1 To 30000, 1 To 39), ARR5(1 To 30000, 1 To 39), ARR6(1 To 30000, 1 To 39), ARR7(1 To 30000, 1 To 39), ARR8(1 To 30000, 1 To 39)
    Dim WB As Workbook

        '** 使用FileDialog对象来选择文件夹
        Dim strPath As String '选择文件路径
        strPath = Application.GetOpenFilename(FileFilter:= _
                    "Excel Files(*.xls;*.xlsx),*.*", Title:="请选择文件")
        '** 取消则退出
        If Len(Dir(strPath)) = 0 Then Exit Sub

    Set WB = Workbooks.Open(Filename:=strPath)
    y = WB.Sheets("正单").[Match(1, 0 / (D:D <> ""))]
    arr = WB.Sheets("正单").Range("A4:AH" & y)     这个地方要遍历“正单、样品单、补单”三个工作表的VBA代码修改
    For x = 1 To UBound(arr, 1)

        If 2 <= Now - arr(x, 14) And arr(x, 4) <> "" And arr(x, 14) <> "" And arr(x, 16) = "" And arr(x, 34) = "" Then
            m = m + 1
         For y = 1 To UBound(arr, 2)
            ARR1(m, y) = arr(x, y)
         Next y
       End If

        If 2 <= Now - arr(x, 16) And arr(x, 4) <> "" And arr(x, 16) <> "" And arr(x, 17) = "" And arr(x, 34) = "" Then
            n = n + 1
         For y = 1 To UBound(arr, 2)
            ARR2(n, y) = arr(x, y)
         Next y
       End If

        If 1 <= Now - arr(x, 17) And arr(x, 4) <> "" And arr(x, 17) <> "" And arr(x, 18) = "" And arr(x, 34) = "" Then
            o = o + 1
         For y = 1 To UBound(arr, 2)
            ARR3(o, y) = arr(x, y)
         Next y
       End If

        If 3 <= Now - arr(x, 18) And arr(x, 4) <> "" And arr(x, 18) <> "" And arr(x, 19) = "" And arr(x, 34) = "" Then
            p = p + 1
         For y = 1 To UBound(arr, 2)
            ARR4(p, y) = arr(x, y)
         Next y
       End If

        If 2 <= Now - arr(x, 19) And arr(x, 4) <> "" And arr(x, 19) <> "" And arr(x, 20) = "" And arr(x, 34) = "" Then
            q = q + 1
         For y = 1 To UBound(arr, 2)
            ARR5(q, y) = arr(x, y)
         Next y
       End If

        If 1 <= Now - arr(x, 20) And arr(x, 4) <> "" And arr(x, 20) <> "" And arr(x, 22) = "" And arr(x, 34) = "" Then
            r = r + 1
         For y = 1 To UBound(arr, 2)
            ARR6(r, y) = arr(x, y)
         Next y
       End If

        If 3 <= Now - arr(x, 22) And arr(x, 4) <> "" And arr(x, 22) <> "" And arr(x, 23) = "" And arr(x, 34) = "" Then
            s = s + 1
         For y = 1 To UBound(arr, 2)
            ARR7(s, y) = arr(x, y)
         Next y
       End If

    Next x

    WB.Close True
    Set WB = Nothing

    With ThisWorkbook

        .Sheets(1).Range("A4:AH" & y).ClearContents
         If m > 0 Then
        .Sheets(1).Range("B4").Resize(m, 17) = ARR1
        .Sheets(1).Range("A4:AI" & m + 2).Borders.LineStyle = xlContinuous
        .Sheets(1).Range("A4").Resize(m, 15).Sort key1:=.Sheets(1).[O4], Header:=xlNo
        End If

        .Sheets(2).Range("A4:AH" & y).ClearContents
         If n > 0 Then
        .Sheets(2).Range("B4").Resize(n, 18) = ARR2
        .Sheets(2).Range("A4:AI" & n + 2).Borders.LineStyle = xlContinuous
        .Sheets(2).Range("A4").Resize(n, 17).Sort key1:=.Sheets(2).[Q4], Header:=xlNo
        End If

        .Sheets(3).Range("A4:AH" & y).ClearContents
         If o > 0 Then
        .Sheets(3).Range("B4").Resize(o, 19) = ARR3
        .Sheets(3).Range("A4:AI" & o + 2).Borders.LineStyle = xlContinuous
        .Sheets(3).Range("A4").Resize(o, 18).Sort key1:=.Sheets(3).[r4], Header:=xlNo
        End If

        .Sheets(4).Range("A4:AH" & y).ClearContents
         If p > 0 Then
        .Sheets(4).Range("B4").Resize(p, 20) = ARR4
        .Sheets(4).Range("A4:AI" & p + 2).Borders.LineStyle = xlContinuous
        .Sheets(4).Range("A4").Resize(p, 19).Sort key1:=.Sheets(4).[S4], Header:=xlNo
        End If

        .Sheets(5).Range("A4:AH" & y).ClearContents
         If q > 0 Then
        .Sheets(5).Range("B4").Resize(q, 21) = ARR5
        .Sheets(5).Range("A4:AI" & q + 2).Borders.LineStyle = xlContinuous
        .Sheets(5).Range("A4").Resize(q, 20).Sort key1:=.Sheets(5).[T4], Header:=xlNo
        End If

        .Sheets(6).Range("A4:AH" & y).ClearContents
         If r > 0 Then
        .Sheets(6).Range("B4").Resize(r, 23) = ARR6
        .Sheets(6).Range("A4:AI" & r + 2).Borders.LineStyle = xlContinuous
        .Sheets(6).Range("A4").Resize(r, 21).Sort key1:=.Sheets(6).[U4], Header:=xlNo
        End If

        .Sheets(7).Range("A4:AH" & y).ClearContents
         If s > 0 Then
        .Sheets(7).Range("B4").Resize(s, 24) = ARR7
        .Sheets(7).Range("A4:AI" & s + 2).Borders.LineStyle = xlContinuous
        .Sheets(7).Range("A4").Resize(s, 23).Sort key1:=.Sheets(7).[W4], Header:=xlNo
        End If

    End With
    Application.ScreenUpdating = True
End Sub

最佳答案
2017-9-21 15:05
  1. Set WB = Workbooks.Open(Filename:=strPath)
  2. xrr = Array("正单", "样品单", "补单")
  3. For Each shnm In xrr
  4.     y = WB.Sheets(shnm).[Match(1, 0 / (D:D <> ""))]
  5.     arr = WB.Sheets(shnm).Range("A4:AH" & y)
  6.     For x = 1 To UBound(arr, 1)
  7.     ' .......
  8.     Next
  9. Next
复制代码
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2017-9-21 15:05 | 显示全部楼层    本楼为最佳答案   
  1. Set WB = Workbooks.Open(Filename:=strPath)
  2. xrr = Array("正单", "样品单", "补单")
  3. For Each shnm In xrr
  4.     y = WB.Sheets(shnm).[Match(1, 0 / (D:D <> ""))]
  5.     arr = WB.Sheets(shnm).Range("A4:AH" & y)
  6.     For x = 1 To UBound(arr, 1)
  7.     ' .......
  8.     Next
  9. Next
复制代码
回复

使用道具 举报

 楼主| 发表于 2017-9-21 17:46 | 显示全部楼层

Array("正单", "样品单", "补单")这3个工作表的数据要都在后面的数据表一次显示,怎么样修改代码
回复

使用道具 举报

 楼主| 发表于 2017-9-23 16:33 | 显示全部楼层

后面导入的数据表格我需要增加现在的时间与数据对应的时间的实际差额天数怎么增加代码了
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 00:14 , Processed in 0.471018 second(s), 8 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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