|
楼主 |
发表于 2019-3-13 14:50
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
看来只能自娱自乐了,哈哈
公布代码(由于我有多个sheet表,因此做个了通用的。):
- Sub 销售额导入()
- Dim mypath$, myname$
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- For i = 8 To Range("a65536").End(xlUp).Row
- If Range("B" & i).Value = "Saturday" Or Range("B" & i).Value = "Sunday" Then
- Application.Intersect(Columns("a:v"), Range("A" & i).EntireRow).Select
- With Selection.Interior
- .ColorIndex = 15
- End With
- End If
- Next
- mypath = ThisWorkbook.Path & ""
- myname = Dir(mypath & "Monthly Report.xlsx")
- If myname <> ThisWorkbook.Name Then
- Set wb = Workbooks.Open(ThisWorkbook.Path & "" & myname)
- With wb.Worksheets(1)
- ReDim ar(1 To 38, 1 To 4)
- ReDim br(1 To 38, 1 To 2)
- For i = 5 To 35
- If .Cells(i, 2) <> "" Then
- n = n + 1
- ar(n, 1) = .Cells(i, 1)
- ar(n, 2) = .Cells(i, 2)
- ar(n, 3) = .Cells(i, 11)
- ar(n, 4) = .Cells(i, 12)
- br(n, 1) = .Cells(i, 13)
- br(n, 2) = .Cells(i, 14)
- End If
- Next i
- End With
- End If
- With ThisWorkbook.ActiveSheet
- .Cells(8, 1).Resize(n, 4) = ar
- .Cells(8, 10).Resize(n, 2) = br
- End With
- ActiveWorkbook.Close False
- Application.ScreenUpdating = True
- Application.DisplayAlerts = True
- End Sub
复制代码 |
|