|
Sub grfInput()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Open Filename:="C:\Users\OGP SZ\Desktop\Data.xls"
ActiveWindow.SmallScroll Down:=-9
Range("B1").Select
Selection.copy
Windows("D2001.xls").Activate
Range("G3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Data.xls").Activate
Range("A2:B30").Select
Application.CutCopyMode = False
Selection.copy
ActiveWindow.Close
Windows("D2001.xls").Activate
ActiveWindow.SmallScroll Down:=6
Range("F12:G39").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=12
ActiveWindow.SmallScroll Down:=-18
Range("F12:G39").Select
ActiveWindow.SmallScroll Down:=-33
ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range("F12:F39") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("sheet1").Sort
.SetRange Range("F12:G39")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim j&, sh As Worksheet
For Each sh In Worksheets
With sh
For j = 7 To .Columns.Count
If Application.CountA(.Cells(12, j).Resize(180)) = 0 Then Exit For
Next j
.[G3].copy .Cells(3, j)
.[G12:G39].copy .Cells(12, j)
End With
Next sh
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
前半部分是录制的宏,看起来好杂乱,求老师帮忙优化一下,程序在附件的D2001 文件中
- Sub grfInput()
- Dim wb As Workbook, mywb As Workbook
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set mywb = ThisWorkbook
- Set wb = Workbooks.Open(mywb.Path & "\Data.xls")
- mywb.Sheets(1).[g3] = wb.Sheets(1).[b1]
- mywb.Sheets(1).[f12:g40] = wb.Sheets(1).Range("a2:b30").Value
- wb.Close False
- [f12:g39].Sort key1:=[f12]
-
- Dim j&, sh As Worksheet
- For Each sh In Worksheets
- With sh
- For j = 7 To .Columns.Count
- If Application.CountA(.Cells(12, j).Resize(180)) = 0 Then Exit For
- Next j
- .[g3].copy .Cells(3, j)
- .[G12:G39].copy .Cells(12, j)
- End With
- Next sh
- Application.ScreenUpdating = True
- Application.DisplayAlerts = True
- End Sub
复制代码
|
|