求助解决保存时出现“下标越界”的问题

hyqzzs

新时代新征途 发表于 2018-8-5 15:56
老师您好！有个问题请您帮忙解决。因为在4个半月前您曾经帮我解决过同样的问题，所以，今天还拜托您帮我 ...

不明白你说的“请把保存路径更改为现在的这种形式”是什么意思，稍微修改了一下，你看看吧。有问题再说

Sub 保存()
    Application.ScreenUpdating = False
    With ThisWorkbook.ActiveSheet
        cs = .[e5].Value
        If .[g11] = "" Then MsgBox "请输入第一日期": GoTo 100
        sj = Format([g11].Value, "m") & "月份"
        f = Dir(ThisWorkbook.Path & "\" & cs & ".xls*")
        
        If f = "" Then MsgBox "无此文件！！": GoTo 100
        Do While f <> ""
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f)
            Set sh = wb.Worksheets(sj)
            r = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
            ar = .Range("g9:g13")
            br = .Range("g14:g20")
            cr = .Range("j9:j12")
            dr = .Range("j16:j19")
            crr = .Range("m9:m11")
            sh.Cells(r, 1).Resize(1, UBound(ar)) = Application.Transpose(ar)
            sh.Cells(r, 6).Resize(1, UBound(br)) = Application.Transpose(br)
            sh.Cells(r, 13).Resize(1, UBound(cr)) = Application.Transpose(cr)
            sh.Cells(r, 17).Resize(1, UBound(dr)) = Application.Transpose(dr)
            sh.Cells(r, 21).Resize(1, UBound(crr)) = Application.Transpose(crr)
            sh.Cells(r, 1).Resize(1, 23).Borders.LineStyle = xlContinuous
            wb.Close True
            f = Dir
        Loop
    End With
100:
    Application.ScreenUpdating = True
End Sub