- ©«¤l
- 2798
- ¥DÃD
- 10
- ºëµØ
- 0
- ¿n¤À
- 2854
- ÂI¦W
- 0
- §@·~¨t²Î
- ¡e²¤¡f
- ³nÅ骩¥»
- ¡e²¤¡f
- ¾\ŪÅv
- 100
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¡e²¤¡f
- µù¥U®É¶¡
- 2013-5-13
- ³Ì«áµn¿ý
- 2024-4-20
|
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)
>>>> |
|