返回列表 上一主題 發帖

[發問] 簡化程式

luke

帖子
140 
主題
37 
精華
0 
積分
193 
點名
0  
作業系統
Windows XP 
軟體版本
Office 2007 
閱讀權限
20 
註冊時間
2012-3-28 
最後登錄
2015-7-5 

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-5-13 13:06 | 只看該作者

[發問] 簡化程式

本帖最後由 luke 於 2012-5-13 13:07 編輯

各位大大

小弟用錄製了巨集修改如下
Sub CC()
Set fd = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
Set FT = ActiveWorkbook
FS = "D:\TEST\TEST20\" & "TT.txt"
With Workbooks.Open(FS).Sheets("TT")
     FT.Sheets("Sheet2").Columns("A:B") = .Columns("A:B").Value
    .Parent.Close False
End With
Application.ScreenUpdating = True

Set fd = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
Set FT = ActiveWorkbook
FS = "D:\TEST\TEST20\TEST\" & "TT.txt"
With Workbooks.Open(FS).Sheets("TT")
     FT.Sheets("Sheet2").Columns("G:H") = .Columns("A:B").Value
    .Parent.Close False
End With
Application.ScreenUpdating = True

Set fd = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
Set FT = ActiveWorkbook
FS = "D:\TEST\TEST20\" & "UU.csv"
With Workbooks.Open(FS).Sheets("UU")
     FT.Sheets("Sheet2").Columns("C") = .Columns("A").Value
    .Parent.Close False
End With
Application.ScreenUpdating = True
End Sub
Sub DD()
Application.ScreenUpdating = False
Set FT = ActiveWorkbook
FS = "D:\TEST\TEST20\" & "TT.txt"
With Workbooks.Open(FS).Sheets("TT")
     FT.Sheets("Sheet2").Columns("D:E").Copy .Columns("A:B")
    .Parent.Close savechanges:=True
End With
Application.ScreenUpdating = True

Application.ScreenUpdating = False
Set FT = ActiveWorkbook
FS = "D:\TEST\TEST20\TEST\" & "TT.txt"
With Workbooks.Open(FS).Sheets("TT")
     FT.Sheets("Sheet2").Columns("G:H").Copy .Columns("A:B")
    .Parent.Close savechanges:=True
End With
Application.ScreenUpdating = True
sheet2.[f1:f5] = [c1:c5].Value
    Range("F6").Select
    ActiveCell.FormulaR1C1 = "=""Count=""&COUNT(R[-5]C[-2]:RC[-2])"
    Range("F7").Select
    ActiveCell.FormulaR1C1 = "=""Lan""&R[-6]C[-2]&""=""&R[-6]C[-1]"
    Range("F7").Select
    Selection.Copy
    Range("F8:F9").Select
    ActiveSheet.Paste
    Range("F6:F9").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.ScreenUpdating = False
Set FT = ActiveWorkbook
FS = "D:\TEST\TEST20\" & "UU.csv"
With Workbooks.Open(FS).Sheets("UU")
     FT.Sheets("Sheet2").Columns("F").Copy .Columns("A")
    .Parent.Close savechanges:=True
End With
Application.ScreenUpdating = True
End Sub

煩請先進 大大指導簡化程式
收藏 分享

play9091

帖子
87 
主題
24 
精華
0 
積分
122 
點名
0  
作業系統
win 7 
軟體版本
2016 
閱讀權限
20 
性別
男 
註冊時間
2011-7-9 
最後登錄
2018-1-16 
2#
發表於 2012-5-13 18:26 | 只看該作者
看完整段後……這應該是在不同的檔案，對不同的區域，做相同的事情……

這或許可以用array
把"區域"，"檔案路俓"，各別創建array，然後用迴圈的方式取出array裡相對應的值，做相同的動作……

提供點想法……試著做做看！
初學VBA乍到twbts

TOP

luke

帖子
140 
主題
37 
精華
0 
積分
193 
點名
0  
作業系統
Windows XP 
軟體版本
Office 2007 
閱讀權限
20 
註冊時間
2012-3-28 
最後登錄
2015-7-5 

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
3#
發表於 2012-5-13 19:27 | 只看該作者
回復 2# play9091


    回覆 卓大大

   小弟對語法不太了解, 目前只會用拼裝方式把相關程式湊在一起, 因此不會用array語法
   
   謝謝你的建議

TOP

play9091

帖子
87 
主題
24 
精華
0 
積分
122 
點名
0  
作業系統
win 7 
軟體版本
2016 
閱讀權限
20 
性別
男 
註冊時間
2011-7-9 
最後登錄
2018-1-16 
4#
發表於 2012-5-13 21:44 | 只看該作者
本帖最後由 play9091 於 2012-5-13 21:58 編輯

回復 3# luke


    試試看這樣子可不可以吧！我不知道在物件裡面可不可以放arr()，不行的話再把它拿出來好了！先試試看這樣子！
  1. Sub CC()
  2. Dim arr1, arr2, arr3, arr4
  3. arr1 = Array("D:\TEST\TEST20\TT.txt", "D:\TEST\TEST20\TEST\TT.txt", "D:\TEST\TEST20\UU.csv")
  4. arr2 = Array("TT", "TT", "UU")
  5. arr3 = Array("A:B", "G:H", "C")
  6. arr4 = Array("A:B", "A:B", "A")
  7. Set fd = CreateObject("Scripting.FileSystemObject")
  8. Application.ScreenUpdating = False
  9. For I = 1 To 3
  10. Set FT = ActiveWorkbook
  11. FS = arr1(I)
  12. With Workbooks.Open(FS).Sheets(arr2(I))
  13.      FT.Sheets("Sheet2").Columns(arr3(I)) = .Columns(arr4(I)).Value
  14.     .Parent.Close False
  15. End With
  16. Next I
  17. End Sub


  20. Sub DD()
  21. Dim arr1, arr2, arr3, arr4
  22. arr1 = Array("D:\TEST\TEST20\TT.txt", "D:\TEST\TEST20\TEST\TT.txt", "D:\TEST\TEST20\UU.csv")
  23. arr2 = Array("TT", "TT", "UU")
  24. arr3 = Array("D:E", "G:H", "F")
  25. arr4 = Array("A:B", "A:B", "A")
  26. Application.ScreenUpdating = False
  27. Set FT = ActiveWorkbook
  28. For I = 1 To 3
  29. Set FT = ActiveWorkbook
  30. FS = arr1(I)
  31. With Workbooks.Open(FS).Sheets(arr2(I))
  32.      FT.Sheets("Sheet2").Columns(arr3(I)) = .Columns(arr4(I)).Value
  33.     .Parent.Close False
  34. End With
  35. Next I
  36. sheet2.[f1:f5] = [c1:c5].Value
  37.     Range("F6").FormulaR1C1 = "=""Count=""&COUNT(R[-5]C[-2]:RC[-2])"
  38.     Range("F7").FormulaR1C1 = "=""Lan""&R[-6]C[-2]&""=""&R[-6]C[-1]"
  39.     Range("F7").Copy Range("F8:F9")
  40.     Range("F6:F9").Copy
  41.     Selection.PasteSpecial Paste:=xlPasteValues
  42. End Sub
複製代碼
初學VBA乍到twbts

TOP

luke

帖子
140 
主題
37 
精華
0 
積分
193 
點名
0  
作業系統
Windows XP 
軟體版本
Office 2007 
閱讀權限
20 
註冊時間
2012-3-28 
最後登錄
2015-7-5 

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
5#
發表於 2012-5-13 22:47 | 只看該作者
回復 4# play9091


    回覆大大

    重新整理後如下說明:

    Sheet1表A:B欄匯入D:\TT.txt, C欄匯入D:\UU.csv, G:H欄匯入D:\123\TT.txt.

   完成後將A:C欄移至D:F欄, G:H欄固定不動
   修改後再分別將D:E欄存至D:\TT.txt,F欄存至D:\UU.csv, G:H欄存至D:\123\TT.txt

  請問與法如何修改?
   TEST20A.rar (13.46 KB)

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
267  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-10-31 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
6#
發表於 2012-5-13 23:23 | 只看該作者
回復 5# luke


    這樣文字檔內容不是都沒改變嗎?
不知道你真正目的何在?
學海無涯_不恥下問

TOP

luke

帖子
140 
主題
37 
精華
0 
積分
193 
點名
0  
作業系統
Windows XP 
軟體版本
Office 2007 
閱讀權限
20 
註冊時間
2012-3-28 
最後登錄
2015-7-5 

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
7#
發表於 2012-5-13 23:57 | 只看該作者
本帖最後由 luke 於 2012-5-14 09:47 編輯

回復 6# Hsieh


    回覆H超版

    說明見附檔紅字部分

     煩請先進 大大指導
    TEST20B.rar (17.93 KB)

TOP

        靜思自在 : 做好事不能少我一人，做壞事不能多我一人。
返回列表 上一主題