-
Sub GetFileList() Dim xFSO As Object Dim xFolder As Object Dim xFile As Object Dim xPath As String Dim i As Integer Dim location As Range xPath = "C:\Program Files" Set xFSO = CreateObject("Scripting.FileSystemObject") Set xFolder = xFSO.GetFolder(xPath) Set location = Worksheets(1).Range("A5") location.Value = "Folder name" location.Offset(0, 1) = "File name" location.Offset(0, 2) = "File extension" i = 0 For Each xFile In xFolder.Files i = i + 1 location.Offset(i, 0) = xPath location.Offset(i, 1) = Left(xFile.Name, InStrRev(xFile.Name, ".") - 1) location.Offset(i, 2) = Mid(xFile.Name, InStrRev(xFile.Name, ".") + 1) Next End Sub
הכתובת נמצאת במקטע Worksheets(1).Range("A5")
ה1 זה מס' הגליון, תוכל להחליף זאת במספר אחר או בשם (אבל מוקף מרכאות). -
@dovid
אני רואה כי הדלת פתוחה
אז אני מרשה לעצמי לשאול
תוכל לתת לי הקוד הנל
אבל שהנתיב תיקיה יופנה לתא בגיליון (שבו יהיה רשום הנתיב תיקיה)
כמובן רק אם זה לא מטריח אותך... -
@מתמחה-במחשבים אמר בעריכת קוד VBA באקסל:
@dovid
אני רואה כי הדלת פתוחה
אז אני מרשה לעצמי לשאול
תוכל לתת לי הקוד הנל
אבל שהנתיב תיקיה יופנה לתא בגיליון (שבו יהיה רשום הנתיב תיקיה)
כמובן רק אם זה לא מטריח אותך...ניסיתי לעשות בעצמי
כך שבמקוםxPats
(המשתנה בסוגריים)
הכנסתיrange("גיליון1!H5").value
הרעיון לעצמו עובד
אך שאני מפעיל אותו הוא לוקח זמן רב
איפה טעיתי? -
@dovid
קודם תודה רבה על הציון לשבחעליתי על מתי שקורה לי הבעיה
אקדים בקצרה
בניתי שני כפתורים באקסל
כפתור אחד מאקרו שמציב נתיב תיקיה שבחרתי (בדו שיח)
וכפתור שני שמציב רשימת קבצים (חוברות עבודה) שנמצאים בתוך התיקיהכעת שאני מפעיל הכפתור השני לרענון הרשימת הקבצים עובד ללא דופי
אך שאני מפעיל הכפתור הראשון שאמור להציב את הנתיב של התיקיה, לוקח לו זמן רב (מחשב 4 הליכי משנה וכו')
ככל הנראה, מכיוון שהמאקרו השני שואב את הרשימת קבצים לפי נתיב בתא שהמאקרו הראשון מציב, כנראה שיוצרת בעיה מסויימתאם תרצה אתאר לשם מה אני משתמש בזה
-
@dovid
זה הקוד כפתור ראשוןSub browseFolderPath() On Error GoTo err Dim fileExplorer As FileDialog Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker) 'To allow or disable to multi select fileExplorer.AllowMultiSelect = False With fileExplorer If .Show = -1 Then 'Any folder is selected ['גיליון5'!H1] = .SelectedItems.Item(1) Else ' else dialog is cancelled MsgBox "עליך לבחור נתיב תיקיה מתאימה" End If End With err: Exit Sub End Sub
-
@dovid אמר בעריכת קוד VBA באקסל:
משונה, הקוד הזה רץ אצלי בלי רגע של שיהוי.
יש לתא הזה השפעה על תא אחר כל שהוא?
נקוד של הכפתור השני מופעל אוטומטית בשינוי של הראשון או רק לאחר לחיצה?כשאני מחזיר את המאקרו של הכפתור השני לנוסח המקורי (נתיב תיקייה קבועה)
אז אין שום בעייה
ושניהם פועלים יפה ללא דופי
רק מתי שאני משנה לתא שהוצב ע"י הכפתור השני אזי הכפתור השני נתקע -
@dovid אמר בעריכת קוד VBA באקסל:
נקוד של הכפתור השני מופעל אוטומטית בשינוי של הראשון או רק לאחר לחיצה?
רק לאחר לחיצה
-
@dovid אמר בעריכת קוד VBA באקסל:
משונה, הקוד הזה רץ אצלי בלי רגע של שיהוי.
עשיתי גם בגיליון חדש והפעלתי שני המאקרוים ועובדים ללא דופי יחד
כעת אני יודע שהבעיה הוא לא במאקרואין לי מושג איפה קבור הכלב
-
@dovid
בסייעתא דשמיא מצאתי את הכלב
מתברר שהיה לי קוד (פונקציה מותאמת אישית) נוסף (שעבד מאד טוב)
ששאב את הנתון מתא של נתיב קובץ (שהוצב ע"י המאקרו הנל)
התברר שכל פעם שאני משנה את הנתיב של הקובץ הוא מבצע החישובים שוב (דבר שלוקח זמן שמדובר בכמות תאים)
ולא שמתי לב לזה מכיוון שלפני ששמתי את המאקרו לא שיניתי כלל את הנתיב (כי לא היה צורך)בכל אופן תודה רבה על הרצון לסייע!!!
-
שיניתי את הקוד הבעייתי לקוד שיציג תיבת אזהרה על כך שייקח זמן רב
Sub browseFolderPath() On Error GoTo err Dim fileExplorer As FileDialog Dim answer As Integer answer = MsgBox("לאחר בחירה מחדש של התיקיית דוחות, יש להמתין מס' דקות כדי לחשב מחדש, האם אתה רוצה להמשיך?", vbYesNo + vbExclamation + vbDefaultButton2 + vbMsgBoxRtlReading) If answer = vbYes Then Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker) 'To allow or disable to multi select fileExplorer.AllowMultiSelect = False With fileExplorer If .Show = -1 Then 'Any folder is selected ['גיליון5'!H1] = .SelectedItems.Item(1) Else ' else dialog is cancelled MsgBox "עליך לבחור נתיב תיקיה מתאימה" End If End With err: Exit Sub MsgBox "הנתיב שצוין הוא" & vbNewLine & vbNewLine & Range("'גיליון5'!H1").Value Else 'do nothing End If End Sub
-
פוסט זה נמחק!
-