[µo°Ý] Àx¦s®æ¯Á¤Þ­È

PJChen

¦U¦ì¥ý¶i¦n,

·Q½Ð±Ð¤@­ÓVBAªº¼gªk
§Ú±Nµ{¦¡©Ò¦bªºÀx¦s®æ
B1³]¬°­n°õ¦æªºÀɮצWºÙ
B2³]¬°¤u§@ªí¦WºÙ,¥B¥H¼Æ¦r©R¦W
B3³]¬°±q²ÄN­Ósheet¶}©l°_ºâ
B4³]¬°¤@­Ó¤é´Áªº­È
°ÝÃD¡G
¥H¤Uµ{¦¡¼gªk,¥u¯à¯Á¤Þ¨ì­n°õ¦æªºÀÉ®×¥h,¨ä¥L³£¤£°_§@¥Î,
¨Ò¦p¡G
B2¥»¨Ó¬O«ü¦V¯S©w¤u§@ªí,¦ý¦]¬°¥H¼Æ¦r©R¦W,´N³Q·í¦¨¬O²Än­Ó¤u§@ªí,¦Ñ¬O¶]¿ùsheet
B3«hÁÙ¼g¤£¥X¨Ó
B4©Ò³]©wªº¤é´Á,«hµLªk¶K¤W«ü©wªºsheet

½Ð°Ý¥H¤Uµ{¦¡¸Ó¦p¦ó­×§ï¡H

1. Sub ´ú¸Õ()
   
2. Dim Wb As Workbook, Sh As Worksheet, x As Range
   
3.     Set Wb = Workbooks(Workbooks("Macro.xlsm").Worksheets("VBA").Range("B1").Value) 'Àx¦s®æªº­È¬°ÀɮצWºÙ
   
4.     Set Sh = Wb.Worksheets(Worksheets("VBA").Range("B2").Value) 'Àx¦s®æªº­È¬°¤u§@ªí¦WºÙ
   
5.     Sh.Activate
   
6.     With Sh
   
7.     Set x = .Range("B4")
   
8.     x = Range("B4").Value '«ü©w1.sheet¤é´Á
   
9.     End With
   
10. End Sub

½Æ»s¥N½X

¤U¸ü (16.4 KB)
¤u§@ªí

2019-4-21 16:20

PJChen

¦^´_ 14# ­ã´£³¡ªL

¦nªº,·PÁ¡I

­ã´£³¡ªL

¦^´_ 13# PJChen


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

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

PJChen

¦^´_ 12# ­ã´£³¡ªL

ÁÂÁ­ã¤j,

µ{¦¡°õ¦æ¨S°ÝÃD¤F,§Ú¸ÕµÛ§â¸ô®|Åܧ󦨳o¼Ë,¤w¸g¥i¥H¥Î¤F¡I
Path = "W:\¨p\½d¨Ò\"
P = Path & "\" & P & "\"

­ã´£³¡ª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

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

PJChen

¦^´_ 8# ­ã´£³¡ªL
¦^´_ 10# ChuckBucket

¤G¦ì¦n,
³o¬q®É¶¡,¤@¦³¾÷·|´N¶i¦æ´ú¸Õ,¦ýµL½×¦p¦ó,µ{¦¡°õ¦æµ²ªGÁÙ¬O¦³°ÝÃD,½ÐÀ°¦£¸Ñ´b... ´ú¸Õ2.rar (48.68 KB)

¤U¸ü¦¸¼Æ: 2

2019-5-17 20:38

°õ¦æµ{¦¡ªº°ÝÃD:(§Ú§â°õ¦æµ²ªG¯d¦bÀɮפ¤,§Æ±æ¦³§U©ó¤F¸Ñ­ì¦])
°õ¦æ«á¥u¦³3­ÓÀÉ,«o¦C¤F100¦h¦æ
¥u´ú¤F3­ÓÀÉ,¦ýRun±o¦³ÂI¤[,¤£ª¾°ÝÃD¥X¦b­þ?
°õ¦æ«á¤£»Ý­n§âÀɮצWºÙ¦C¥X¨Ó
¥»¨Ó¦Û¦æ§â¥H¤U¤G¦æÅܦ¨µù¸Ñ,¦ýÁÙ¬O·|¼g¦b¨ä¥LÄæ¦ì,½Ð°Ý¸Ó¦p¦ó­×§ïµ{¦¡,¤~¯àÅý¥¦¤£­n§âÀɮצWºÙ¦C¥X?
[F1:H999].ClearContents:  Set xA = [F1]
If Not xS Is Nothing Then xS.Range(R) = T: xB.Save: xA(1, 3) = "(V)¼g¤J§¹¦¨"
·í¸ê®Æ§¨Åܧó¸ô®|®É,¸Ó¦p¦ó­×§ï¼gªk?¨Ò¦p:¸ô®|§ï¬°W:\0_¦Û­qªí³æ\¤é±`ªí®æ\
»Pµ{¦¡¤£¦b¦P¤@¸ê®Æ§¨®É?

ChuckBucket

¦^´_ 9# PJChen


«¢ÅoPJ¡A

§Ú¤£²M·¡©p¹ê»Ú¸m¤Jµ{§ÇªºEXCEL¿ï¾Ü¬°¦ó¥H¤Î¸ê®Æ§¨¦ì¸m©Ò¦b³B¡A¦ý§Ú¬O±NMACROA¥H¤Î¸ê®Æ§¨©ñ¦b¦P¤@¸ô®|¤U¡A¨Ã¦b¦¹«e´£¤U´ú¸Õ­ã¤jªºµ{§Ç¬O¥i¦æªº¡C
¥¼µo¥Í©p©Ò´£ªº´`Àô«Üªø¦Ü168¦C¡C
«Øij©p¥i¶i¤Jµ{§Ç·í¤¤¡A±N¨C¤@­ÓÅܼƳ£¥[¤J·s¼WºÊ¬Ý¦¡¡A³v¦æÆ[¬Ý¡A¬Ý¬O­þ¤@­Ó¦a¤è¶}©l¡A¦³«D¹w´Áªº±¡ªpµo¥Í¡C(¦p¹Ï¤ù©Òµø)

¤U¸ü (116.94 KB)

2019-5-1 15:01

P.S.§Ú¦³¦b­ã¤jµ{§Ç¸ÌÀY¡A³Æµù¤@¤U¦U¦æ·N«ä¨Ñ©p¥H¤Î¨ä¥L¤H°Ñ¦Ò(¥¼§ó°Ê­ã¤jªºµ{§Ç)¡C

    Macro.A_¥[¤J³Æµù¨Ñ°Ñ¦Ò.rar (21.94 KB)

¤U¸ü¦¸¼Æ: 0

2019-5-1 14:46

PJChen

¦^´_ 8# ­ã´£³¡ªL

¤j¤j¦n,
§Ú§ï¤FÀɦW,µ{¦¡¦bMacro.AµLªk°õ¦æ,¸Õ¤F«Ü¦h¦¸³£¤£¦æ¡I¥i¬O¶K¦b¥¿¦¡ª©¤S¥i¥H,¥Î§AªºÀɮפ]¥i¥H,§Ú¬d¤£¥X­ì¦],¥i§_À°¦£¬Ý¤@¤U?
¤£¹L´N¨º¦¸°õ¦æ¦³¨Ç°ÝÃD:
1. Macro.A¬O§Ú¥Î¨Ó´ú¸Õªº,¥¿¦¡ª©ªº¸Ì­±¦³«Ü¦hªºVBA,³o­Óµ{¦¡°õ¦æ«á,·|À°§Ú¶K¤W
¨Î¨Å-¥þ¥x.xlsx
¤ñµá¦h-OK.xlsx
¤ñµá¦h-¥þ¥x.xlsx
³o¤T­ÓÀÉ"(V)¼g¤J§¹¦¨",¦bF:H,¦Ó¥B©ú©ú¥u¦³¤T­ÓÀÉ,¥¦«o¶K¤F«Ü¦h¦¸,¤@ª½´`Àô«Üªø¤@¦ê¦Ü168¦C,
³o·|§â§Ú¥¿¦¡ª©ªºMacro.xlsmªºª©­±¯}Ãa±¼,©Ò¥H§Ú§â¼g¤Jªº¥\¯à¼È®É¨ú®ø,
2. ·í¸ê®Æ§¨¤£¬O¦bMacro.xlsmªº¦P¤@­Ó¦a¤è,¦Ó¬O¨ä¥¦¸ô®|®É,§ï¦¨¥H¤U¬O§_¥¿½T?
¨Ò¦p W:\­ÜÀx¦@¥Î\C,§ï¼g¸ô®| P = .Path & "W:\­ÜÀx¦@¥Î\C &"\"
´ú¸Õ3.rar (41.64 KB)

¤U¸ü¦¸¼Æ: 4

2019-4-28 22:02

­ã´£³¡ª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

>>>>

PJChen

¦^´_ 6# jcchiang

±z¦n,

Workbooks("Macro.xlsm").Worksheets("VBA").Range("B1")Àx¦s®æÁö¦³«ü¦WÀɦW,¦ý¬Oµ¹¨ä¥Lµ{¦¡¥Îªº,
¦b³o­Óµ{¦¡¤¤,§Ú¬O·Q¨Ì§Ç¼g¤J«ü©wªº­È¨ìA¸ê®Æ§¨ªº©Ò¦³Àɮפ¤(¤£¥]§t¤l¸ê®Æ§¨),©Ò¥H¤£¯à¥Î«ü¦WÀɦW¤è¦¡.