[發問] 請問如何用vba來將模組或代碼寫入另一個excel

因為檔案需要更新但有上千個檔案變成要一一打開匯入模組...
http://blog.xuite.net/crdotlin/excel/7633898-%E7%94%A8VBA%E4%BE%86%E7%94%A2%E7%94%9FVBA
只找到一個但是檔案已失效

樓主熱帖

lpk187

高中生 Rank: 3 Rank: 3

帖子: 552
主題: 3
精華: 0
積分: 578
點名: 0
作業系統: win7
軟體版本: office 2010
閱讀權限: 50
性別: 男
註冊時間: 2015-2-8
最後登錄: 2024-7-9

2016猴年全勤獎章 2015羊年全勤獎章熱烈參與勳章

5^#

發表於 2016-8-16 10:47 | 只看該作者

回復 3# starry1314

Option Explicit
Public Sub ex()
Dim s As String
Dim VBCom As Object
Dim VBP
On Error Resume Next
   Do
      Err = 0
      Set VBP = ActiveWorkbook.VBProject
      If Err <> 0 Then
         If MsgBox("巨集安全設置置不允許代代碼進行行操作。" & vbCrLf & vbCrLf & "請將信任中心內信任存取VBA專案物件模型勾選", vbCritical + vbYesNo, "巨集設定") = vbYes Then
            With Application
                  .SendKeys "t"
                  .CommandBars.FindControl(ID:=3627).Execute
            End With
         Else
            Exit Sub
         End If
      End If
Loop Until Err = 0
On Error GoTo 0
s = "sub 合計()" & vbCrLf '
s = s & " Dim rng1 As Range, rng2 As Range" & vbCrLf
s = s & " Dim 日期 As Date" & vbCrLf
s = s & " With Sheets(1)" & vbCrLf '
s = s & "       號碼 = .Cells(3, 18)" & vbCrLf
s = s & "       日期 = .Cells(2, 19)" & vbCrLf
s = s & "       Set rng1 = .Columns(1).Find(號碼)" & vbCrLf
s = s & "       Set rng2 = .Rows(1).Find(日期, LookIn:=xlValues)" & vbCrLf
s = s & "       .Cells(3, 19) = .Cells(rng1.Row, rng2.Column).Value" & vbCrLf
s = s & " End With" & vbCrLf '
s = s & "End Sub"
Set VBCom = ThisWorkbook.VBProject.VBComponents.Add(1) '插入模組
VBCom.Name = "模組1" '變更模組名稱
With VBCom.CodeModule
      .InsertLines .CountOfLines + 1, s '寫入代碼
End With
End Sub

TOP

lpk187

高中生 Rank: 3 Rank: 3

帖子: 552
主題: 3
精華: 0
積分: 578
點名: 0
作業系統: win7
軟體版本: office 2010
閱讀權限: 50
性別: 男
註冊時間: 2015-2-8
最後登錄: 2024-7-9

2016猴年全勤獎章 2015羊年全勤獎章熱烈參與勳章

4^#

發表於 2016-8-16 10:45 | 只看該作者

回復 3# starry1314

給你一個大概的模型，其他的請自行修改內容
以下代碼必須在工具>>設定引用項目中，引用 Microsoft Visual Basic For Application Extensibility 5.3<<這個要勾選

Option Explicit
Public Sub ex()
Dim s As String
Dim VBCom As Object
Dim VBP
On Error Resume Next
Do
Err = 0
Set VBP = ActiveWorkbook.VBProject
If Err <> 0 Then
If MsgBox("巨集安全設置置不允許代代碼進行行操作。" & vbCrLf & vbCrLf & "請將信任中心內信任存取VBA專案物件模型勾選", vbCritical + vbYesNo, "巨集設定") = vbYes Then
With Application
.SendKeys "t"
.CommandBars.FindControl(ID:=3627).Execute
End With
Else
Exit Sub
End If
End If
Loop Until Err = 0
On Error GoTo 0
s = "sub 合計()" & vbCrLf '
s = s & " Dim rng1 As Range, rng2 As Range" & vbCrLf
s = s & " Dim 日期 As Date" & vbCrLf
s = s & " With Sheets(1)" & vbCrLf '
s = s & " 號碼 = .Cells(3, 18)" & vbCrLf
s = s & " 日期 = .Cells(2, 19)" & vbCrLf
s = s & " Set rng1 = .Columns(1).Find(號碼)" & vbCrLf
s = s & " Set rng2 = .Rows(1).Find(日期, LookIn:=xlValues)" & vbCrLf
s = s & " .Cells(3, 19) = .Cells(rng1.Row, rng2.Column).Value" & vbCrLf
s = s & " End With" & vbCrLf '
s = s & "End Sub"
Set VBCom = ThisWorkbook.VBProject.VBComponents.Add(1) '插入模組
VBCom.Name = "模組1" '變更模組名稱
With VBCom.CodeModule
.InsertLines .CountOfLines + 1, s '寫入代碼
End With
End Sub