¤u§@ªí¥t¦s·sÀÉ©M¥HÀx¦s®æ¤º®e©R¦W

missbb

·Q½Ð±Ð¦³¤@­Ó¬¡­¶³¡, ­n±N²Ä2±i, ²Ä3±i©M²Ä4±iWORKSHEET­n¥t¦s¬°3­Ó¿W¥ßWORKBOOK,  ·í¤¤VLOOKUP¸ê®ÆÂର­È, ®æ¦¡¤£ÅÜ.

ÀÉ®×Àx¦s¸ô®|°Ñ·ÓWORKSHEET¤ºRANGE("G1")

¬¡­¶³¡¦WºÙ°Ñ·ÓWORKSHEET¤º¤ºRANGE("G2")

½Ð¦h¦hÀ°¦£:) ¤u§@ªí¥t¦sÀɮרåHÀx¦s®æ¤º®e©R¦W.zip (10.68 KB)

¤U¸ü¦¸¼Æ: 6

2023-12-5 00:06

Andy2483

¦^´_ 1# missbb


    ÁÂÁ½׾Â,ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨ÒÀÉ
«á¾ÇÂǦ¹©«½m²ß¦r¨å(ÀˬdÀɦW­«½Æ),¾Ç²ß¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò
Option Explicit
Sub TEST()
Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim A, Z, i&, T$, T1$, T2$, F1 As Range, F2 As Range
Set Z = CreateObject("Scripting.Dictionary")
T1 = "¥t¦sÀɮ׸ô®|": T2 = "¥t¦sÀɮצWºÙ"
For i = 1 To Worksheets.Count
   Set F1 = Sheets(i).[1:1].Find(T1, Lookat:=xlWhole)
   Set F2 = Sheets(i).[2:2].Find(T2, Lookat:=xlWhole)
   If F1 Is Nothing Or F2 Is Nothing Then GoTo i01 Else T = F2(1, 2) & "/S"
   If Z(T) <> "" Then MsgBox F2(1, 2) & " ÀɦW­«½Æ,½ÐÀˬd": Exit Sub
   Z(T) = F1(1, 2) & "": Set Z(F2(1, 2) & "") = Sheets(i)
i01: Next
For Each A In Z.KEYS
   If Not IsObject(Z(A)) Then GoTo A01 Else T = Z(A & "/S")
   Z(A).Copy: If Dir(T, vbDirectory) = "" Then MkDir T
   With ActiveSheet.UsedRange: .Value = .Value: End With
   With ActiveWorkbook: .SaveAs Filename:=T & "\" & A: .Close: End With
   ThisWorkbook.Activate
A01: Next
End Sub

missbb

¦^´_ 2# Andy2483

¦hÁ«ü¹D, :'(

missbb

¦^´_ 3# missbb


  ·Q¦A¦h°Ý, ¦pªG¦b¤u§@ªí³]©w¤F¦C¦L½d³ò(¤u§@ªí1©M2©Î¦³¤£¦P) , ¥t¦s·sÀɮɤ£·QÅã¥ÜÄæF ªº¸ô®|©MÀɮצW¦r, À³¦bVBA CODE¤º¨º¸Ì­×§ï?

«ô°U«ü¾É

Andy2483

¦^´_ 4# missbb


    ÁÂÁ«e½ú¦^´_,­×§ï¦p¤U,½Ð«e½ú°Ñ¦Ò
¦C¦L½d³ò(¤u§@ªí1©M2©Î¦³¤£¦P):¸g´ú¸Õ ­ì¤u§@ªí¦C¦L½d³ò·|±a¨ì·s½Æ»sªº³]©w

Option Explicit
Sub TEST()
Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim A, Z, i&, T$, T1$, T2$, F1 As Range, F2 As Range
Set Z = CreateObject("Scripting.Dictionary")
T1 = "¥t¦sÀɮ׸ô®|": T2 = "¥t¦sÀɮצWºÙ"
For i = 1 To Worksheets.Count
   Set F1 = Sheets(i).[1:1].Find(T1, Lookat:=xlWhole)
   Set F2 = Sheets(i).[2:2].Find(T2, Lookat:=xlWhole)
   If F1 Is Nothing Or F2 Is Nothing Then GoTo i01 Else T = F2(1, 2) & "/S"
   If Z(T) <> "" Then MsgBox F2(1, 2) & " ÀɦW­«½Æ,½ÐÀˬd": Exit Sub
   Z(T) = F1(1, 2) & "": Set Z(F2(1, 2) & "") = Sheets(i): Z(F2(1, 2) & "/a") = F1.Address
i01: Next
For Each A In Z.KEYS
   If Not IsObject(Z(A)) Then GoTo A01 Else T = Z(A & "/S")
   Z(A).Copy: If Dir(T, vbDirectory) = "" Then MkDir T
   With ActiveSheet.UsedRange: .Value = .Value: End With
   Range(Z(A & "/a")).Resize(2, 2) = ""
   With ActiveWorkbook: .SaveAs Filename:=T & "\" & A: .Close: End With
   ThisWorkbook.Activate
A01: Next
End Sub

missbb

¦^´_ 5# Andy2483


    «D±`·PÁÂ!

missbb

¦^´_  missbb


    ÁÂÁ«e½ú¦^´_,­×§ï¦p¤U,½Ð«e½ú°Ñ¦Ò
¦C¦L½d³ò(¤u§@ªí1©M2©Î¦³¤£¦P):¸g´ú¸Õ ­ì¤u§@ªí ...
Andy2483 µoªí©ó 2023-12-5 14:16

§A¦n , ¤@ª½¦b¸Õ¥Î , ²{®É¥i¬O±N¥þ³¡¤u§@ªí2,¤u§@ªí3©M¤u§@ªí4¥t¦s¬°·sªºWORKBOOK.  ¦ý¦pªG¥u­n¤u§@ªí2©M¤u§@ªí4¥t¦sWORKSBOOK (¤S©Î¬O¥u¥t¦s¤u§@ªí4µ¥¤£¦P±¡ªp), ¥i§_¥ÎINPUT BOX¿é¤J¨Ó¨î§@?  :(

Andy2483

¦^´_ 7# missbb


    ÁÂÁ«e½ú¦A«ü±Ð
1.³¡¤À¥t¦sªº·N¸q¬°¦ó?
¥t¦sªº¥Ø¼Ð¸ê®Æ§¨¦ì¸m³£¤@¼Ë,§Y¨Ï¬O³¡¤À¥t¦s,³o¨Ç¥t¦sÀÉÁÙ¬O²V¦P¤@¸ê®Æ§¨¸Ì,¨ú¥Î¤@¼Ë»Ý­n¦bÀÉ®×Á`ºÞ¬D¿ï,©Ò¥H³¡¤À¥t¦s·|Åܱo·N¸q¤£¤j,³o¬O·|¦³¦¹ºÃ°Ýªº­ì¦]

2.©Î»¡©ú³o¨Ç¥t¦sªº¥Î³~.¥t¦sÀW²v....µ¥

3.¦pªG¥u¬O¦C¦L«á¥t¦s,¥i°Ñ¦Ò¥H¤UÃìµ²©«
https://forum.twbts.com/viewthre ... mp;page=2#pid122046

missbb

¦^´_ 8# Andy2483


    ¦]¬°¤u§@»Ý­n¡A¥¼¥²¨C¦¸³£­n¥t¦s©Ò¦³¤u§@ªí¡C§Ú·|°Ñ·Ó§A´£¨Ñªº¸ê®Æ¦A¸Õ¡A«D±`·PÁÂ:)

singo1232001

¦^´_ 9# missbb


    Sub ¦P¸ê®Æ§¨¾É¥X()

Set outSh = ActiveSheet
Set myBook = ThisWorkbook
        
Filename = outSh.[G2].Value & " " & Format(Now, "yyyyMMdd_HHnnss") & ".xlsx"
' ³]©wÀɮ׫O¦s¸ô®|¡]§ó§ï¬°©Ò»Ý¸ô®|¡^
filePath = myBook.Path & "\" & Filename

outSh.Copy
Set NewWorkbook = ActiveWorkbook
    ' «O¦s·s¤u§@ï
NewWorkbook.SaveAs Filename:=filePath
End Sub


Sub G1G2¥t¦s¸ô®|¾É¥X()

Set outSh = ActiveSheet
Set myBook = ThisWorkbook
        
Filename = outSh.[G2].Value & " " & Format(Now, "yyyyMMdd_HHnnss") & ".xlsx"
' ³]©wÀɮ׫O¦s¸ô®|¡]§ó§ï¬°©Ò»Ý¸ô®|¡^
filePath = Range("G1").Value & "\" & Filename

outSh.Copy
Set NewWorkbook = ActiveWorkbook
    ' «O¦s·s¤u§@ï
NewWorkbook.SaveAs Filename:=filePath
End Sub



Sub ¸ê®Æ¿ï¾Ü¾¹¸ô®|¾É¥X()


Set fd = Excel.Application.FileDialog(msoFileDialogFolderPicker)  '³]©w¿ï¨úÀÉ®×¥\¯à
fd.InitialFileName = Excel.ActiveWorkbook.Path  '³]©w¹w³]¥Ø¿ý
fd.Show 'Åã¥Ü¹ï¸Ü®Ø
If fd.SelectedItems.Count = 0 Then Exit Sub
Set myBook = ThisWorkbook
Set outSh = ActiveSheet
myPath = fd.SelectedItems(1)

Filename = outSh.[G2].Value & " " & Format(Now, "yyyyMMdd_HHnnss") & ".xlsx"
' ³]©wÀɮ׫O¦s¸ô®|¡]§ó§ï¬°©Ò»Ý¸ô®|¡^
filePath = Range("G1").Value & "\" & Filename

outSh.Copy
Set NewWorkbook = ActiveWorkbook
    ' «O¦s·s¤u§@ï
NewWorkbook.SaveAs Filename:=filePath
End Sub