Sub 測試()
Dim Wb As Workbook, sh As String, x As Range
' Set Wb = Workbooks(Workbooks("Macro.xlsm").Worksheets("VBA").Range("B1").Value) '儲存格的值為檔案名稱
sh = Worksheets("VBA").Range("B2") '儲存格的值為工作表名稱
Worksheets(sh).Activate
With Worksheets(sh)
Set x = .Range("B4")
x = Worksheets("VBA").Range("B4").Value '指定1.sheet日期
End With
End Sub作者: jcchiang 時間: 2019-4-24 16:09
Sub 測試()
Dim Wb As Workbook, Sh As Worksheet, x As Range, Source1 As String
Source1 = Workbooks("Macro.xlsm").Worksheets("VBA").Range("B1").Value '要開啟的檔案名稱
Workbooks.Open "c:\A\" & Source1 & ".xlsx" '開啟要寫入的檔案
Workbooks("Macro.xlsm").Activate
Set Wb = Workbooks(Workbooks("Macro.xlsm").Worksheets("VBA").Range("B1").Value) '儲存格的值為檔案名稱
Set Sh = Wb.Worksheets(Worksheets("VBA").Range("B2").Text) '儲存格的值為工作表名稱,因為工作表名稱是數字,會被當成"數第N個工作表",還無法解決,以加1先暫用
Sh.Activate
With Sh
Set x = Sh.Range(Workbooks("Macro.xlsm").Worksheets("VBA").Range("B5").Text) '指定寫入的儲存格為放在那個欄位
x = Workbooks("Macro.xlsm").Worksheets("VBA").Range("B4").Text '寫人的值放在那個欄位
End With
Workbooks(Dir("C:\A\" & Source1 & ".xlsx")).Close True '關閉並儲存寫入的檔案
End Sub作者: PJChen 時間: 2019-4-26 21:52
Sub 測試()
Dim P$, S$, T$, R$, F$, N&, xA As Range, xB As Workbook, xS As Worksheet
P = [B6]: If P = "" Then MsgBox "**子資料夾未輸入! ": Exit Sub
P = ThisWorkbook.Path & "\" & P & "\"
If Dir(P, vbDirectory) = "" Then MsgBox "**子資料夾不存在! ": Exit Sub
S = [B2]: If S = "" Then MsgBox "**工作表名稱未輸入! ": Exit Sub
T = [B4].Text: If S = "" Then MsgBox "**寫入的內容未輸入! ": Exit Sub
R = [B5]: If R = "" Then MsgBox "**寫入位址未輸入! ": Exit Sub
On Error Resume Next: Set xA = Range(R): On Error GoTo 0
If xA Is Nothing Then MsgBox "**寫入位址不正確! ": Exit Sub
If xA.Count > 1 Then MsgBox "**寫入位址不是單一儲存格! ": Exit Sub
'--------------------------------------------------------------------
[F1:H999].ClearContents: Set xA = [F1]
Application.ScreenUpdating = False
Do
If F = "" Then F = Dir(P & "*.xls") Else F = Dir() 'xls 自行改成 xlsx
If F = "" Then Exit Do
N = N + 1: xA = N: xA(1, 2) = F: xA(1, 3) = "(X)工作表不存在"
Set xB = Workbooks.Open(P & F): Set xS = Nothing
On Error Resume Next: Set xS = xB.Sheets(S): On Error GoTo 0
If Not xS Is Nothing Then xS.Range(R) = T: xB.Save: xA(1, 3) = "(V)寫入完成"
Set xA = xA(2): xB.Close 0
Loop
End Sub
執行程式的問題:(我把執行結果留在檔案中,希望有助於了解原因)
執行後只有3個檔,卻列了100多行
只測了3個檔,但Run得有點久,不知問題出在哪?
執行後不需要把檔案名稱列出來
本來自行把以下二行變成註解,但還是會寫在其他欄位,請問該如何修改程式,才能讓它不要把檔案名稱列出?
[F1:H999].ClearContents: Set xA = [F1]
If Not xS Is Nothing Then xS.Range(R) = T: xB.Save: xA(1, 3) = "(V)寫入完成"
當資料夾變更路徑時,該如何修改寫法?例如:路徑改為W:\0_自訂表單\日常表格\
與程式不在同一資料夾時?作者: 准提部林 時間: 2019-5-18 09:31
Sub 測試()
Dim P$, S$, T$, R$, F$, N&, xB As Workbook, xS As Worksheet
P = [B6]: If P = "" Then MsgBox "**資料夾名稱,子資料夾未輸入! ": Exit Sub
P = ThisWorkbook.Path & "\" & P & "\"
If Dir(P, vbDirectory) = "" Then MsgBox "**子資料夾不存在! ": Exit Sub
S = [B2]: If S = "" Then MsgBox "**工作表名稱未輸入! ": Exit Sub
T = [B4].Text: If S = "" Then MsgBox "**寫入的內容未輸入! ": Exit Sub
R = [B5]: If R = "" Then MsgBox "**寫入位址未輸入! ": Exit Sub
On Error Resume Next: Set xA = Range(R): On Error GoTo 0
If xA Is Nothing Then MsgBox "**寫入位址不正確! ": Exit Sub
If xA.Count > 1 Then MsgBox "**寫入位址不是單一儲存格! ": Exit Sub
'--------------------------------------------------------------------
Dim xD, A
Set xD = CreateObject("Scripting.Dictionary")
Do
If F = "" Then F = Dir(P & "*.xlsx") Else F = Dir()
If F = "" Then Exit Do Else xD(F) = ""
Loop
If xD.Count = 0 Then Exit Sub
Application.ScreenUpdating = False
For Each A In xD.keys
Set xB = Workbooks.Open(P & A): Set xS = Nothing
On Error Resume Next: Set xS = xB.Sheets(S): On Error GoTo 0
If Not xS Is Nothing Then xS.Range(R) = T: xB.Save
xB.Close 0
Next
End Sub
