Excel精英培训网

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

[已解决]求老师帮忙优化程序

[复制链接]
发表于 2017-7-14 11:12 | 显示全部楼层 |阅读模式
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 文件中





最佳答案
2017-7-14 11:29
  1. Sub grfInput()
  2.     Dim wb As Workbook, mywb As Workbook
  3.     Application.ScreenUpdating = False
  4.     Application.DisplayAlerts = False
  5.     Set mywb = ThisWorkbook
  6.     Set wb = Workbooks.Open(mywb.Path & "\Data.xls")
  7.     mywb.Sheets(1).[g3] = wb.Sheets(1).[b1]
  8.     mywb.Sheets(1).[f12:g40] = wb.Sheets(1).Range("a2:b30").Value
  9.     wb.Close False
  10.     [f12:g39].Sort key1:=[f12]
  11.    
  12.     Dim j&, sh As Worksheet
  13.     For Each sh In Worksheets
  14.       With sh
  15.         For j = 7 To .Columns.Count
  16.            If Application.CountA(.Cells(12, j).Resize(180)) = 0 Then Exit For
  17.         Next j
  18.         .[g3].copy .Cells(3, j)
  19.         .[G12:G39].copy .Cells(12, j)
  20.        End With
  21.     Next sh
  22.     Application.ScreenUpdating = True
  23.     Application.DisplayAlerts = True
  24. End Sub
复制代码

D.rar

40.31 KB, 下载次数: 3

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2017-7-14 11:29 | 显示全部楼层    本楼为最佳答案   
  1. Sub grfInput()
  2.     Dim wb As Workbook, mywb As Workbook
  3.     Application.ScreenUpdating = False
  4.     Application.DisplayAlerts = False
  5.     Set mywb = ThisWorkbook
  6.     Set wb = Workbooks.Open(mywb.Path & "\Data.xls")
  7.     mywb.Sheets(1).[g3] = wb.Sheets(1).[b1]
  8.     mywb.Sheets(1).[f12:g40] = wb.Sheets(1).Range("a2:b30").Value
  9.     wb.Close False
  10.     [f12:g39].Sort key1:=[f12]
  11.    
  12.     Dim j&, sh As Worksheet
  13.     For Each sh In Worksheets
  14.       With sh
  15.         For j = 7 To .Columns.Count
  16.            If Application.CountA(.Cells(12, j).Resize(180)) = 0 Then Exit For
  17.         Next j
  18.         .[g3].copy .Cells(3, j)
  19.         .[G12:G39].copy .Cells(12, j)
  20.        End With
  21.     Next sh
  22.     Application.ScreenUpdating = True
  23.     Application.DisplayAlerts = True
  24. End Sub
复制代码
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 05:50 , Processed in 0.295999 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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