[發問] 請問各位前輩關於多個excel設定欄位問題

ii31sakura

不好意思、請問前輩們一下~
小弟此vba功能為針對同一個資料夾下的所有excel中的(Sheet1)的第9~14欄位進行設定欄位大小為(13.5)，
但因句集中"欄位轉換"使用open方式進行修改、故如果小弟的excel有超過50筆以上則需花上不少時間，
能否請問前輩、小弟的內容是否有其它方式可進行修改呢？


註：Sheet1為固定處理分頁

轉換test檔.rar (19.19 KB)

下載次數: 2

2014-9-17 17:56

感謝~

程式碼：(有點長..)

Sub 標案名稱轉換()
   
    Sheets("轉換頁").[a2:a65535].ClearContents
    Worksheets("轉換頁").Cells(1, 2) = ActiveWorkbook.Path
    fs = Dir(Worksheets("轉換頁").Cells(1, 2) & "\*.*")
Do Until fs = ""
r = r + 1
Worksheets("轉換頁").Cells(r + 1, 1) = fs
fs = Dir
Loop

End Sub

Sub 標案名稱轉換1() '刪除其它非excel檔案

Dim LastRow As Long, r As Long

    '判斷最後使用的列，將這個列數指派給 LastRow 變數

    LastRow = Worksheets("轉換頁").UsedRange.Rows.Count

    'LastRow 的計算方式：判斷使用範圍中的列數，加上使用範圍中第一個列數，再減去 1

    LastRow = LastRow + Worksheets("轉換頁").UsedRange.Row - 1

    Application.ScreenUpdating = False

    '迴圈使用 Step -1 會由下而上進行處理，當刪除列之後會將所有下方的列往上移動。
   

   
    '此區塊為刪除"非xl*檔"
    For r = LastRow To 2 Step -1

       If Worksheets("轉換頁").Cells(r, 1) Like "*xl*" Then
       Else
       Worksheets("轉換頁").Rows(r).Delete
       End If
    Next r
   
  '此區塊為刪除"轉換test檔 "字列
    For r = LastRow To 2 Step -1

       If Worksheets("轉換頁").Cells(r, 1) Like "轉換test檔*" Then Worksheets("轉換頁").Rows(r).Delete
    Next r


End Sub
Sub 欄位轉換()

    Dim wb(1 To 2) As Workbook
      Application.DisplayAlerts = False '是用來略過刪除時提醒的對話方塊, 若還要確認, 則可不用此指令
      
    Set wb(1) = ThisWorkbook
    For i = 2 To wb(1).Worksheets("轉換頁").[a65536].End(3).Row
    Set wb(2) = Workbooks.Open(Worksheets("轉換頁").Cells(1, 2) & "\" & Worksheets("轉換頁").Cells(i, 1))
   
   
   
     wb(2).Worksheets("Sheet1").Rows("9:14").Select
        Selection.RowHeight = 13.5
            
        
   

    wb(2).Close True

Next

Application.DisplayAlerts = True

    Set wb(1) = Nothing
    Set wb(2) = Nothing

End Sub

Sub 資料總呼叫()
    Call 標案名稱轉換
    Call 標案名稱轉換1
    Call 欄位轉換

End Sub

luhpro

不好意思、請問前輩們一下~
小弟此vba功能為針對同一個資料夾下的所有excel中的(Sheet1)的第9~14欄位進行設 ...
ii31sakura 發表於 2014-9-17 17:56

以下是個人的淺見,你可以參考看看:

1. 基本上要對檔案 "內容" 作變更應該都是要先開檔的,
    除非你是用早期DOS時代低階寫入磁碟資料的方式來直接寫入磁面,
    但這並不會被Windows系統接受,
    也幾乎會被歸入是病毒的行為.

2. 善用 With...End With 來取代需 "被重複使用" 的 "物件",
    善用 "變數" 來取代需 "被重複使用" 的 "計算結果",
    尤其是 For...Next 或 Do...Loop ...等迴圈中經常會參考到的東西,
    速度較快也有利於程式碼的辨識與除錯,
    當然若只使用一次, 那就別用了.

3. 除非必需要用到(例如使用者需要看到, 或某些需要參照到現用物件的專屬指令碼),
    否則 Select 或 Activate 指令請儘量少用,
    那會浪費一些非必要的時間(尤其是在迴圈中, 會重複執行很多次的情形).

4. 程式碼可以適當使用縮排(左端加空格)與空白行, 增加辨識與除錯的便利性.

程式修改如下,因無資料可以先行測試結果,若有問題再請提出:

1. Sub 標案名稱轉換()
   
2.   With Sheets("轉換頁")
   
3.     .[a2:a65535].ClearContents
   
4.     .Cells(1, 2) = ActiveWorkbook.Path
   
5.     fs = Dir(.Cells(1, 2) & "\*.*")
   
6.     Do Until fs = ""
   
7.       r = r + 1
   
8.       .Cells(r + 1, 1) = fs
   
9.       fs = Dir
   
10.     Loop
    
11.   End With
    
12. End Sub
    
13. 
    
14. Sub 標案名稱轉換1() '刪除其它非excel檔案
    
15.   Dim LastRow As Long, r As Long
    
16.     '判斷最後使用的列，將這個列數指派給 LastRow 變數
    
17. 
    
18.   With Worksheets("轉換頁")
    
19.     LastRow = .UsedRange.Rows.Count
    
20.     'LastRow 的計算方式：判斷使用範圍中的列數，加上使用範圍中第一個列數，再減去 1
    
21.     LastRow = LastRow + .UsedRange.Row - 1
    
22.     Application.ScreenUpdating = False
    
23.     '迴圈使用 Step -1 會由下而上進行處理，當刪除列之後會將所有下方的列往上移動。
    
24.     '此區塊為刪除"非xl*檔"
    
25.     For r = LastRow To 2 Step -1
    
26.        If .Cells(r, 1) Like "*xl*" Then
    
27.        Else
    
28.          .Rows(r).Delete
    
29.        End If
    
30.     Next r
    
31.   '此區塊為刪除"轉換test檔 "字列
    
32.     For r = LastRow To 2 Step -1
    
33.       If .Cells(r, 1) Like "轉換test檔*" Then .Rows(r).Delete
    
34.     Next r
    
35.   End With
    
36. End Sub
    
37. 
    
38. Sub 欄位轉換()
    
39.   Dim lRows&
    
40.   Dim wb As Workbook
    
41.    
    
42.   Application.DisplayAlerts = False '是用來略過刪除時提醒的對話方塊, 若還要確認, 則可不用此指令
    
43.   With ThisWorkbook.Worksheets("轉換頁")
    
44.     lRows = .[a65536].End(3).Row
    
45.     For i = 2 To lRows
    
46.       Set wb = Workbooks.Open(.Cells(1, 2) & "\" & .Cells(i, 1))
    
47.        wb.Worksheets("Sheet1").Rows("9:14").RowHeight = 13.5
    
48.       wb.Close True
    
49.     Next
    
50.   End With
    
51.   Application.DisplayAlerts = True
    
52.   Set wb = Nothing
    
53. End Sub
    
54. 
    
55. Sub 資料總呼叫()
    
56.     Call 標案名稱轉換
    
57.     Call 標案名稱轉換1
    
58.     Call 欄位轉換
    
59. End Sub

複製代碼

ii31sakura

回復 2# luhpro

感謝luhpro前輩細心指導、這個方式執行起來跟原本的執行速度相差好幾倍..尤其是在多檔案情況下時間差距更明顯，
感謝前輩的幫忙指導~