­ã´£³¡ªL

Sub ´ú¸Õ()
Dim P$, S$, T$, R$, F$, N&, xA As Range, xB As Workbook, xS As Worksheet
P = [B6]: If P = "" Then MsgBox "**¤l¸ê®Æ§¨¥¼¿é¤J!¡@": Exit Sub
P = ThisWorkbook.Path & "\" & P & "\"
If Dir(P, vbDirectory) = "" Then MsgBox "**¤l¸ê®Æ§¨¤£¦s¦b!¡@": Exit Sub
S = [B2]: If S = "" Then MsgBox "**¤u§@ªí¦WºÙ¥¼¿é¤J!¡@": Exit Sub
T = [B4].Text: If S = "" Then MsgBox "**¼g¤Jªº¤º®e¥¼¿é¤J!¡@": Exit Sub
R = [B5]: If R = "" Then MsgBox "**¼g¤J¦ì§}¥¼¿é¤J!¡@": Exit Sub
On Error Resume Next: Set xA = Range(R): On Error GoTo 0
If xA Is Nothing Then MsgBox "**¼g¤J¦ì§}¤£¥¿½T!¡@": Exit Sub
If xA.Count > 1 Then MsgBox "**¼g¤J¦ì§}¤£¬O³æ¤@Àx¦s®æ!¡@": 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)¤u§@ªí¤£¦s¦b"
   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)¼g¤J§¹¦¨"
   Set xA = xA(2):  xB.Close 0
Loop
End Sub

´ú¸Õ(1).rar (23.65 KB)

¤U¸ü¦¸¼Æ: 2

2019-4-27 11:42

>>>>

­ã´£³¡ªL

¦^´_ 11# PJChen


Sub ´ú¸Õ()
Dim P$, S$, T$, R$, F$, N&, xB As Workbook, xS As Worksheet
P = [B6]: If P = "" Then MsgBox "**¸ê®Æ§¨¦WºÙ,¤l¸ê®Æ§¨¥¼¿é¤J!¡@": Exit Sub
P = ThisWorkbook.Path & "\" & P & "\"
If Dir(P, vbDirectory) = "" Then MsgBox "**¤l¸ê®Æ§¨¤£¦s¦b!¡@": Exit Sub
S = [B2]: If S = "" Then MsgBox "**¤u§@ªí¦WºÙ¥¼¿é¤J!¡@": Exit Sub
T = [B4].Text: If S = "" Then MsgBox "**¼g¤Jªº¤º®e¥¼¿é¤J!¡@": Exit Sub
R = [B5]: If R = "" Then MsgBox "**¼g¤J¦ì§}¥¼¿é¤J!¡@": Exit Sub
On Error Resume Next: Set xA = Range(R): On Error GoTo 0
If xA Is Nothing Then MsgBox "**¼g¤J¦ì§}¤£¥¿½T!¡@": Exit Sub
If xA.Count > 1 Then MsgBox "**¼g¤J¦ì§}¤£¬O³æ¤@Àx¦s®æ!¡@": 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

===================

­ã´£³¡ªL

¦^´_ 13# PJChen


Path = "W:\¨p\½d¨Ò\"
P = Path & "\" & P & "\"

¬õ¦â³¡¥÷­«ÂШâ­Ó"\",  §R±¼¨ä¤¤¤@­Ó~~~