Note: The other languages of the website are Google-translated. Back to English

كيفية استيراد ملفات نصية متعددة من مجلد إلى ورقة عمل واحدة؟

على سبيل المثال ، لديك هنا مجلد به عدة ملفات نصية ، ما تريد القيام به هو استيراد هذه الملفات النصية في ورقة عمل واحدة كما هو موضح أدناه. بدلاً من نسخ الملفات النصية واحدًا تلو الآخر ، هل هناك أي حيل لاستيراد الملفات النصية بسرعة من مجلد واحد إلى ورقة واحدة؟

استيراد ملفات نصية متعددة من مجلد واحد إلى ورقة واحدة باستخدام VBA

استيراد ملف نصي إلى الخلية النشطة مع كوتولس ل إكسيل فكرة جيدة 3


فيما يلي رمز VBA يمكن أن يساعدك في استيراد جميع الملفات النصية من مجلد معين إلى ورقة جديدة.

1. قم بتمكين مصنف تريد استيراد ملفات نصية ، واضغط على ALT + F11 مفاتيح للتمكين ميكروسوفت فيسوال باسيك للتطبيقات نافذة.

2. انقر إدراج > وحدة، انسخ والصق رمز VBA أدناه إلى ملف وحدة نافذة.

فبا: استيراد ملفات نصية متعددة من مجلد إلى ورقة واحدة

Sub Test()
'UpdatebyExtendoffice6/7/2016
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

3. صحافة F5 لعرض مربع حوار ، وتحديد مجلد يحتوي على ملفات نصية تريد استيرادها. انظر لقطة الشاشة:
doc استيراد ملفات نصية من مجلد 1

4. انقر OK. ثم تم استيراد الملفات النصية إلى المصنف النشط كورقة جديدة بشكل منفصل.
doc استيراد ملفات نصية من مجلد 2


إذا كنت تريد استيراد ملف نصي واحد إلى خلية أو نطاق معين ، فيمكنك تطبيق كوتولس ل إكسيلالصورة إدراج ملف في المؤشر خدمة.

كوتولس ل إكسيل, مع أكثر من 300 وظائف يدوية ، تجعل مهامك أكثر سهولة. 

بعد تركيب مجاني Kutools for Excel ، يرجى القيام بما يلي:

1. حدد خلية تريد استيراد الملف النصي ، وانقر فوق كوتولس بلس > استيراد و تصدير > إدراج ملف في المؤشر. انظر لقطة الشاشة:
doc استيراد ملفات نصية من مجلد 3

2. ثم يظهر مربع حوار ، انقر فوق تصفح لعرض حدد ملف لإدراجها في مربع حوار موضع مؤشر الخلية ، حدد التالي ملفات نصية من القائمة المنسدلة ، ثم اختر الملف النصي الذي تريد استيراده. انظر لقطة الشاشة:
doc استيراد ملفات نصية من مجلد 4

3. انقر اذهب الى > Ok، وتم إدراج ملف تحديد النص في موضع المؤشر ، انظر الصورة:
doc استيراد ملفات نصية من مجلد 5


أفضل أدوات إنتاجية المكتب

Kutools for Excel يحل معظم مشاكلك ويزيد إنتاجيتك بنسبة 80٪

  • إعادة استخدام: أدخل بسرعة الصيغ المعقدة والرسوم البيانية وأي شيء استخدمته من قبل ؛ تشفير الخلايا مع كلمة السر إنشاء قائمة بريدية وإرسال رسائل البريد الإلكتروني ...
  • سوبر فورميولا بار (بسهولة تحرير أسطر متعددة من النص والصيغة) ؛ تخطيط القراءة (قراءة وتحرير أعداد كبيرة من الخلايا بسهولة) ؛ لصق في النطاق المصفى
  • دمج الخلايا / الصفوف / الأعمدة دون فقدان البيانات ؛ تقسيم محتوى الخلايا ؛ ادمج الصفوف / الأعمدة المكررة... منع تكرار الخلايا؛ قارن النطاقات
  • حدد مكرر أو فريد صفوف حدد صفوف فارغة (جميع الخلايا فارغة) ؛ البحث الفائق والبحث الغامض في العديد من المصنفات. تحديد عشوائي ...
  • نسخة طبق الأصل خلايا متعددة بدون تغيير مرجع الصيغة ؛ إنشاء المراجع تلقائيًا إلى أوراق متعددة أدخل الرموز النقطية، مربعات الاختيار والمزيد ...
  • استخراج النص، إضافة نص ، إزالة حسب الموضع ، إزالة الفضاء؛ إنشاء وطباعة المجاميع الفرعية لترحيل الصفحات ؛ التحويل بين محتوى الخلايا والتعليقات
  • سوبر تصفية (حفظ وتطبيق مخططات التصفية على أوراق أخرى) ؛ فرز متقدم حسب الشهر / الأسبوع / اليوم ، التكرار والمزيد ؛ مرشح خاص بواسطة bold، italic ...
  • اجمع بين المصنفات وأوراق العمل؛ دمج الجداول على أساس الأعمدة الرئيسية ؛ تقسيم البيانات إلى أوراق متعددة; تحويل دفعة xls و xlsx و PDF
  • أكثر من 300 ميزة قوية. يدعم Office / Excel 2007-2021 و 365. يدعم جميع اللغات. سهولة النشر في مؤسستك أو مؤسستك. الميزات الكاملة نسخة تجريبية مجانية لمدة 30 يومًا. ضمان استرداد الأموال لمدة 60 يومًا.
علامة تبويب kte 201905

يجلب Office Tab الواجهة المبوبة إلى Office ، ويجعل عملك أسهل بكثير

  • تمكين التحرير والقراءة المبوبة في Word و Excel و PowerPointوالناشر والوصول و Visio والمشروع.
  • فتح وإنشاء مستندات متعددة في علامات تبويب جديدة من نفس النافذة ، بدلاً من النوافذ الجديدة.
  • يزيد من إنتاجيتك بنسبة 50٪ ، ويقلل مئات النقرات بالماوس كل يوم!
أوفيسيتاب القاع
فرز التعليقات حسب
التعليقات (46)
تقييم شنومك من شنومكس · تصنيفات 1
تم تصغير هذا التعليق بواسطة المشرف على الموقع
الاختبار الفرعي ()
'تحديث بواسطةExtendoffice6 / 7 / 2016
خافت xWb كمصنف
خافت xToBook كمصنف
خافت xStrPath كسلسلة
خافت xFileDialog كحوار ملف
خافت x ملف كسلسلة
Dim xFiles كمجموعة جديدة
أنا خافت وطويلة
قم بتعيين xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = خطأ
xFileDialog.Title = "حدد مجلدًا [Kutools for Excel]"
إذا كان xFileDialog.Show = -1 ثم
xStrPath = xFileDialog.SelectedItems (1)
إنهاء حالة
إذا كان xStrPath = "" ثم اخرج من Sub
إذا كان صحيحًا (xStrPath، 1) <> "\" ثم xStrPath = xStrPath & "\"
xFile = Dir (xStrPath & "* .txt")
إذا كان xFile = "" إذن
MsgBox "لم يتم العثور على ملفات" ، vbInformation ، "Kutools for Excel"
خروج الفرعية
إنهاء حالة
القيام أثناء xFile <> ""
xFiles.Add xFile ، xFile
xFile = Dir ()
أنشوطة
تعيين xToBook = ThisWorkbook
إذا كان xFiles.Count> 0 ثم
لأني = 1 إلى xFiles.Count
قم بتعيين xWb = Workbooks.Open (xStrPath & xFiles.Item (I))
xWb.Worksheets (1). النسخ بعد: = xToBook.Sheets (xToBook.Sheets.Count)
على خطأ استئناف التالي
ActiveSheet.Name = xWb.Name
على خطأ GoTo 0
xWb إغلاق خطأ
التالى
إنهاء حالة
نهاية الفرعية

هذا الرمز يساعد لكني أريد

علامة تبويب ، فاصلة منقوطة ، مسافة صحيحة ، كيفية القيام بذلك ، الرجاء مساعدتي
تم تصغير هذا التعليق بواسطة المشرف على الموقع
هل تريد الاحتفاظ بالمسافة (المحددات) بعد تحويل الملفات النصية إلى أوراق؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
هذه هي مشكلتي أيضًا ، هذا الرمز صحيح. ولكن بعد تحويل الملفات النصية إلى Excel ، لا يحتفظ بالمحددات.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
هل يمكنك تحميل الملف النصي والنتيجة التي تريدها بالنسبة لي؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
لدي نفس المشكلة. ملفات txt كلها في أوراق منفصلة ويتجاهل الكود المسافة بين العمودين
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا و Des و PB Rama Murty ، يمكن للكود أدناه تقسيم البيانات إلى أعمدة بناءً على المساحة أو علامة التبويب أثناء استيراد ملف نصي إلى الأوراق. يمكنك المحاولة.

فرعي ImportTextToExcel ()
'تحديث بواسطةExtendoffice20180911
خافت xWb كمصنف
خافت xToBook كمصنف
خافت xStrPath كسلسلة
خافت xFileDialog كحوار ملف
خافت x ملف كسلسلة
Dim xFiles كمجموعة جديدة
أنا خافت وطويلة
خافت xIntRow وطول
خافت xFNum ، xFArr طويل
خافت xStrValue كسلسلة
خافت xRg كمدى
خافت xArr
قم بتعيين xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = خطأ
xFileDialog.Title = "حدد مجلدًا [Kutools for Excel]"
إذا كان xFileDialog.Show = -1 ثم
xStrPath = xFileDialog.SelectedItems (1)
إنهاء حالة
إذا كان xStrPath = "" ثم اخرج من Sub
إذا كان صحيحًا (xStrPath، 1) <> "\" ثم xStrPath = xStrPath & "\"
xFile = Dir (xStrPath & "* .txt")
إذا كان xFile = "" إذن
MsgBox "لم يتم العثور على ملفات" ، vbInformation ، "Kutools for Excel"
خروج الفرعية
إنهاء حالة
القيام أثناء xFile <> ""
xFiles.Add xFile ، xFile
xFile = Dir ()
أنشوطة
تعيين xToBook = ThisWorkbook
على خطأ استئناف التالي
Application.ScreenUpdating = خطأ
إذا كان xFiles.Count> 0 ثم

لأني = 1 إلى xFiles.Count
قم بتعيين xWb = Workbooks.Open (xStrPath & xFiles.Item (I))
xWb.Worksheets (1). النسخ بعد: = xToBook.Sheets (xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb إغلاق خطأ
xIntRow = ActiveCell.CurrentRegion.Rows.Count
بالنسبة إلى xFNum = 1 إلى xIntRow
تعيين xRg = ActiveSheet.Range ("A" & xFNum)
xArr = انقسام (xRg.Text، "")
إذا كان UBound (xArr)> 0 ثم
بالنسبة إلى xFArr = 0 إلى UBound (xArr)
إذا كان xArr (xFArr) <> "" ثم
xRg.Value = xArr (xFArr)
تعيين xRg = xRg.Offset (ColumnOffset: = 1)
إنهاء حالة
التالى
إنهاء حالة
التالى
التالى
إنهاء حالة
Application.ScreenUpdating = ترو
نهاية الفرعية
تم تصغير هذا التعليق بواسطة المشرف على الموقع
ما هي التغييرات المطلوبة إذا كنت تريد تقسيم البيانات إلى أعمدة على أساس الفاصلة
تم تصغير هذا التعليق بواسطة المشرف على الموقع
ما التغييرات التي يجب إجراؤها إذا كنت بحاجة إلى تحويل البيانات إلى أعمدة تستند إلى الفاصلة؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
لقد استخدمت هذا وهو يعمل ولكنني أرغب في حفظ كل شيء في ورقة واحدة لأن كل ورقة هي نفس المعلومات التي هي مجرد ملفات تسجيل من كل يوم.
لذلك أحتاج إلى الجمع بين
كل العناصر الموجودة في المجلد إلى ورقة واحدة
استيراد فرعي CSVsWithReference ()
UpdatebyKutoolsforExcel20151214
خافت xWb كمصنف
خافت xToBook كمصنف
خافت xStrPath كسلسلة
خافت xFileDialog كحوار ملف
خافت x ملف كسلسلة
Dim xFiles كمجموعة جديدة
أنا خافت وطويلة
خافت xIntRow وطول
خافت xFNum ، xFArr طويل
خافت xStrValue كسلسلة
خافت xRg كمدى
خافت xArr
عند الخطأ ، انتقل إلى ErrHandler
قم بتعيين xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = خطأ
xFileDialog.Title = "حدد مجلدًا [Kutools for Excel]"
إذا كان xFileDialog.Show = -1 ثم
xStrPath = xFileDialog.SelectedItems (1)
إنهاء حالة
إذا كان xStrPath = "" ثم اخرج من Sub
إذا كان صحيحًا (xStrPath، 1) <> "\" ثم xStrPath = xStrPath & "\"
اضبط xSht = ThisWorkbook.ActiveSheet
إذا كانت MsgBox ("امسح الورقة الموجودة قبل الاستيراد؟" ، vbYesNo ، "Kutools for Excel") = vbYes ثم xSht.UsedRange.Clear
Application.ScreenUpdating = خطأ
xFile = Dir (xStrPath & "\" & "* .log")
القيام أثناء xFile <> ""
تعيين xWb = Workbooks.Open (xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range ("A" & Rows.Count) .End (xlUp). Offset (1)
xWb إغلاق خطأ
xFile = دير
أنشوطة
Application.ScreenUpdating = ترو
خروج الفرعية
ErrHandler:
MsgBox "لا توجد ملفات txt" ، "Kutools for Excel"
نهاية الفرعية

وهذا الذي يحتوي على مسافات لكل عمود

فرعي ImportTextToExcel ()
'تحديث بواسطةExtendoffice20180911
خافت xWb كمصنف
خافت xToBook كمصنف
خافت xStrPath كسلسلة
خافت xFileDialog كحوار ملف
خافت x ملف كسلسلة
Dim xFiles كمجموعة جديدة
أنا خافت وطويلة
خافت xIntRow وطول
خافت xFNum ، xFArr طويل
خافت xStrValue كسلسلة
خافت xRg كمدى
خافت xArr
قم بتعيين xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = خطأ
xFileDialog.Title = "حدد مجلدًا [Kutools for Excel]"
إذا كان xFileDialog.Show = -1 ثم
xStrPath = xFileDialog.SelectedItems (1)
إنهاء حالة
إذا كان xStrPath = "" ثم اخرج من Sub
إذا كان صحيحًا (xStrPath، 1) <> "\" ثم xStrPath = xStrPath & "\"
xFile = Dir (xStrPath & "* .txt")
إذا كان xFile = "" إذن
MsgBox "لم يتم العثور على ملفات" ، vbInformation ، "Kutools for Excel"
خروج الفرعية
إنهاء حالة
القيام أثناء xFile <> ""
xFiles.Add xFile ، xFile
xFile = Dir ()
أنشوطة
تعيين xToBook = ThisWorkbook
على خطأ استئناف التالي
Application.ScreenUpdating = خطأ
إذا كان xFiles.Count> 0 ثم

لأني = 1 إلى xFiles.Count
قم بتعيين xWb = Workbooks.Open (xStrPath & xFiles.Item (I))
xWb.Worksheets (1). النسخ بعد: = xToBook.Sheets (xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb إغلاق خطأ
xIntRow = ActiveCell.CurrentRegion.Rows.Count
بالنسبة إلى xFNum = 1 إلى xIntRow
تعيين xRg = ActiveSheet.Range ("A" & xFNum)
xArr = انقسام (xRg.Text، "")
إذا كان UBound (xArr)> 0 ثم
بالنسبة إلى xFArr = 0 إلى UBound (xArr)
إذا كان xArr (xFArr) <> "" ثم
xRg.Value = xArr (xFArr)
تعيين xRg = xRg.Offset (ColumnOffset: = 1)
إنهاء حالة
التالى
إنهاء حالة
التالى
التالى
إنهاء حالة
Application.ScreenUpdating = ترو
نهاية الفرعية
تم تصغير هذا التعليق بواسطة المشرف على الموقع
كيف أفعل إذا كان ملف Txt الخاص بي يحتوي على محدد باستخدام الفاصلة؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
يمكنك استخدام Find and Replace fuctuon لاستبدال الفاصلة بمسافة أولاً ، وتطبيق إحدى الطرق المذكورة أعلاه لتحويلها إلى ملف Excel.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
أليست هناك طريقة لتغيير هذا في الكود؟ سأفعل هذا بـ 130 ملفًا
تم تصغير هذا التعليق بواسطة المشرف على الموقع
نفس السؤال
تم تصغير هذا التعليق بواسطة المشرف على الموقع
بالنسبة لأولئك الذين ما زالوا بحاجة إلى المساعدة في هذا الأمر ، استبدل xArr = Split (xRg.Text، "") بـ xArr = Split (xRg.Text، "،").
تم تصغير هذا التعليق بواسطة المشرف على الموقع
عندما أقوم بتشغيل الوحدة النمطية كما هو محدد ، فإنها تضيف كل ملف .txt كصفحة جديدة ، وليس كسطر جديد إلى الورقة الحالية. هل هناك طريقة لتحقيق ذلك كإخراج بدلاً من أوراق جديدة لكل ملف .txt؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
هل تقصد دمج كل الملفات النصية في ورقة واحدة؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
نعم هذا ما أريده أيضًا.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا ، Davinder ، يمكنك تجربة رمز vba أدناه.
Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
    Dim xSht  As Worksheet
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Set xSht = ThisWorkbook.ActiveSheet
    If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
    Application.ScreenUpdating = False
    xFile = Dir(xStrPath & "\" & "*.txt")
    Do While xFile <> ""
        Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
        ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
        xWb.Close False
        xFile = Dir
    Loop
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox "no txt files", , "Kutools for Excel"
End Sub
تم تصغير هذا التعليق بواسطة المشرف على الموقع
الكود مفيد للغاية ، إنه الكود الوحيد الذي وجدته والذي يحصل على ملفات txt بكميات كبيرة ، الإصلاح الذي أحتاجه هو أيضًا ما تبحث عنه جويس ودافيندر.
إنه لاستخراج ملفات .txt ولصقها جميعًا تحت بعضها البعض في عمود معين دعنا نقول العمود "N".

تحتاج أيضًا إلى معرفة ما إذا كان من الممكن إضافة "شرط if" لملفات .txt المستوردة لتكون على النحو التالي.
إذا كانت ملفات .txt تبدأ بالحرف "A" ثم يتم لصقها على "الورقة 1" بدءًا من الخلية "N2"
وإذا كانت ملفات .txt تبدأ بالحرف "B" ، فقم بلصقها على "الورقة 2" بدءًا من الخلية "N2"
آخر MsgBox ليكون "غرض ملف .txt غير معروف".

شكرا لكم مقدما
تم تصغير هذا التعليق بواسطة المشرف على الموقع
لدي هذا الرمز يعمل معي ولكن لا يزال يتعين علي تغيير البعض فيه.

* أريد لصقها على نفس الورقة دون فتح ورقة جديدة ثم نسخها لأنها تستغرق وقتًا أطول.

* تحتاج إلى إدراج شرط شرطي إذا كانت ملفات txt التي تم استيرادها ليتم لصقها في الورقة 1 إذا كانت تبدأ بالحرف A ويتم استيرادها إلى الورقة 2 إذا كانت تبدأ بالحرف B


نسخة اختبار فرعية 3 ()
خافت xWb كمصنف
خافت xToBook كمصنف
خافت xStrPath كسلسلة
خافت xFileDialog كحوار ملف
خافت x ملف كسلسلة
Dim xFiles كمجموعة جديدة
خافت أنا طويلة
خافت الصف الأخير بطول
خافت Rng كمدى
قم بتعيين xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = خطأ
xFileDialog.Title = "حدد مجلدًا [Kutools for Excel]"
إذا كان xFileDialog.Show = -1 ثم
xStrPath = xFileDialog.SelectedItems (1)
إنهاء حالة
إذا كان xStrPath = "" ثم اخرج من Sub
إذا كان صحيحًا (xStrPath، 1) <> "\" ثم xStrPath = xStrPath & "\"
xFile = Dir (xStrPath & "* .txt")
إذا كان xFile = "" إذن
MsgBox "لم يتم العثور على ملفات" ، vbInformation ، "Kutools for Excel"
خروج الفرعية
إنهاء حالة
القيام أثناء xFile <> ""
xFiles.Add xFile ، xFile
xFile = Dir ()
أنشوطة
النطاق ("N2"). حدد
تعيين xToBook = ThisWorkbook
إذا كان xFiles.Count> 0 ثم
بالنسبة إلى i = 1 إلى xFiles.Count
قم بتعيين xWb = Workbooks.Open (xStrPath & xFiles.Item (i))
xWb. تنشيط
تحديد ونسخ بيانات النص
النطاق (التحديد ، التحديد ، النهاية (xlDown)). حدد
الاختيار
xToBook. تنشيط
ActiveSheet.Paste
التحديد والنهاية (xlDown). الإزاحة (1)
على خطأ استئناف التالي
على خطأ GoTo 0
xWb إغلاق خطأ
التالى
إنهاء حالة
نهاية الفرعية
تم تصغير هذا التعليق بواسطة المشرف على الموقع
آسف ، يدي مقيدتان
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا ، يتم تشغيل الكود الخاص بي ولكنه يستورد الملف الأول فقط. تقول أنه كان هناك خطأ في طريقة النسخ. يبرز المصحح سطر التعليمات البرمجية التالي. أيه أفكار؟


xWb.Worksheets (1). النسخ بعد: = xToBook.Sheets (xToBook.Sheets.Count)
تم تصغير هذا التعليق بواسطة المشرف على الموقع
لدي نفس المشكلة ، هل وجدت أي حلول؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا كاتي ،
أعلم أن تعليقك قديم جدًا ، لكنني واجهت نفس المشكلة وقمت بإصلاحها بهذه الطريقة: يجب إدراج الوحدة في مجلد فرعي لمشروع .xlsx النشط. لقد ارتكبت خطأ نسخ الرمز في مجلد فرعي من PERSONAL.XLSB حيث أقوم عادةً بتخزين وحدات الماكرو الخاصة بي ويتم ذلك مع وحدات الماكرو الأخرى ، ولكن ليس مع هذا.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
كيف يمكنك حذف الأوراق في كود vba إذا كنت لا تريد نسخًا مكررة عند إعادة تنفيذ الوحدة؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
عذرًا ، قاسي ، فقط كن حذرًا لتجنب تكرار الاستيراد.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا ، أريد منع إزالة الصفر السابق في Excel.

لقد جربت الكود أدناه ولكنه لا يعمل


الاختبار الفرعي ()
خافت xWb كمصنف
خافت xToBook كمصنف
خافت xStrPath كسلسلة
خافت xFileDialog كحوار ملف
خافت x ملف كسلسلة
Dim xFiles كمجموعة جديدة
أنا خافت وطويلة
خافت ي طالما
قم بتعيين xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = خطأ
xFileDialog.Title = "حدد مجلدًا"
إذا كان xFileDialog.Show = -1 ثم
xStrPath = xFileDialog.SelectedItems (1)
إنهاء حالة
إذا كان xStrPath = "" ثم اخرج من Sub
إذا كان صحيحًا (xStrPath، 1) <> "\" ثم xStrPath = xStrPath & "\"
xFile = Dir (xStrPath & "* .txt")
إذا كان xFile = "" إذن
MsgBox "لم يتم العثور على ملفات" ، vbInformation ، "Kutools for Excel"
خروج الفرعية
إنهاء حالة
القيام أثناء xFile <> ""
xFiles.Add xFile ، xFile
xFile = Dir ()
أنشوطة
تعيين xToBook = ThisWorkbook
إذا كان xFiles.Count> 0 ثم
لأني = 1 إلى xFiles.Count
قم بتعيين xWb = Workbooks.Open (xStrPath & xFiles.Item (I))
ActiveSheet.Cells.NumberFormat = "@" 'هذا لجعل Excel بتنسيق نصي قبل لصق بيانات الملف النصي
xWb.Worksheets (1). النسخ بعد: = xToBook.Sheets (xToBook.Sheets.Count)
على خطأ استئناف التالي
ActiveSheet.Name = xWb.Name
على خطأ GoTo 0
xWb إغلاق خطأ
التالى
إنهاء حالة
نهاية الفرعية
تم تصغير هذا التعليق بواسطة المشرف على الموقع
Pooja ، يمكنك تجربة وظيفة Remove Leading Zeros من Kutools for Excel لإزالة جميع الأصفار البادئة من التحديد بعد الاستيراد.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
لكني لا أريد الإزالة. أريد منع إزالة الصفر السابق.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
إذا كنت تريد الاحتفاظ بالأصفار البادئة ، فيمكنك تنسيقها كتنسيق نصي بواسطة تنسيق الخلية.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا ، كيف يمكنك تعديل هذا الرمز لإدراج ملفات * .txt بالترتيب: 1,2,3,4,5,6,7,8,9,10,11،1,10,11,12,13,14,15,16,17,18,19,2,20,21،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX ، إلخ. حاليًا يقوم الرمز بإدراج الملفات على النحو التالي: XNUMX ، XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX،XNUMX ، إلخ. شكرًا!
تم تصغير هذا التعليق بواسطة المشرف على الموقع
هل هناك أي فرصة لأخذ أسماء الأوراق لجزء معين فقط من أسماء ملفات txt؟

وفقًا للرمز أعلاه ، أخذ اسم الورقة بالكامل.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
شكرا جزيلا هل الوظيفة في مكتب 2007 تتفوق
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا ، يتم تشغيل الكود الخاص بي ولكنه يستورد الملف الأول فقط. تقول أنه كان هناك خطأ في طريقة النسخ. يبرز المصحح سطر التعليمات البرمجية التالي. أيه أفكار؟


xWb.Worksheets (1). النسخ بعد: = xToBook.Sheets (xToBook.Sheets.Count)
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا مارتينو ،
واجهت نفس المشكلة وقمت بحلها عن طريق تغيير هذا السطر:
تعيين xToBook = ThisWorkbook
إلى
تعيين xToBook = ActiveWorkbook
ربما يساعد هذا.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
0

أحتاج إلى مساعدتي ، ليس لدي أي فكرة ، فأنا أريد استيراد ملف نصي متعدد مثل 13000. اسم الملف النصي هو نفسه الخلية على سبيل المثال (c1 = 112 لذا فإن اسم الملف النصي هو 112 أيضًا) يعني أن الملف النصي 112 هو قم باستيراد ملف c112.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
أحتاج إلى مساعدتي ، ليس لدي أي فكرة ، فأنا أريد استيراد ملف نصي متعدد مثل 13000. اسم الملف النصي هو نفسه الخلية على سبيل المثال (c1 = 112 لذا فإن اسم الملف النصي هو 112 أيضًا) يعني أن الملف النصي 112 هو قم باستيراد ملف c112.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
تعمل التعليمات البرمجية ولكنها تستورد كل ملف نصي إلى علامة تبويب جديدة في المصنف. هل لديك أي فكرة عن مكان تغيير هذا الرمز لاستيراد ملف نصي جديد في نفس ورقة العمل أسفل البيانات من الملف النصي الأخير؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
في الكود أدناه ، إذا كنت أرغب في تحديد المجلد بدلاً من تحديد المسار في كل مرة يتم فيها استيراد ملف نصي ، فما الذي يجب أن يقوم به التعديل

كود فبا:

استيراد فرعي CSVsWithReference ()
UpdatebyKutoolsforExcel20151214
خافت xSht كورقة عمل
خافت xWb كمصنف
خافت xStrPath كسلسلة
خافت xFileDialog كحوار ملف
خافت x ملف كسلسلة
عند الخطأ ، انتقل إلى ErrHandler
قم بتعيين xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = خطأ
xFileDialog.Title = "حدد مجلدًا [Kutools for Excel]"
إذا كان xFileDialog.Show = -1 ثم
xStrPath = xFileDialog.SelectedItems (1)
إنهاء حالة
إذا كان xStrPath = "" ثم اخرج من Sub
اضبط xSht = ThisWorkbook.ActiveSheet
إذا كانت MsgBox ("امسح الورقة الموجودة قبل الاستيراد؟" ، vbYesNo ، "Kutools for Excel") = vbYes ثم xSht.UsedRange.Clear
Application.ScreenUpdating = خطأ
xFile = Dir (xStrPath & "\" & "* .txt")
القيام أثناء xFile <> ""
تعيين xWb = Workbooks.Open (xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range ("A" & Rows.Count) .End (xlUp). Offset (1)
xWb إغلاق خطأ
xFile = دير
أنشوطة
Application.ScreenUpdating = ترو
خروج الفرعية
ErrHandler:
MsgBox "لا توجد ملفات txt" ، "Kutools for Excel"
نهاية الفرعية
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبا ، يرجى المحاولة أدناه الرمز
Sub Test()
'UpdatebyExtendoffice6/7/2016
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    xStrPath = "C:\Users\AddinsVM001\Desktop\test" 'Here is the parth you can modify
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

"C: \ Users \ AddinsVM001 \ Desktop \ test" هو مسار المجلد الذي يمكنك استيراد ملف نصي منه ، يرجى تغييره حسب حاجتك.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا ، شكرًا لك على رمز VBA القيّم.
ومع ذلك ، أحتاج إلى رمز لملفات txt المتعددة في "ورقة واحدة في ورقة العمل ، وليس ورقة فردية لكل ملف txt".
ما الذي يجب علي تعديل الرمز الخاص بك لغرضي؟

شكر،
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبا ، يرجى المحاولة أدناه الرمز
Sub Test()
    'UpdatebyExtendoffice 10/26/2022
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Dim J As Long
    Dim xRg As Range
    Dim xSaveRg As Range
    Dim xSh As Worksheet
    
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    Set xSh = xToBook.Sheets.Add
    Set xRg = xSh.Range("A1")
    J = 1
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            Set xSaveRg = xWb.Worksheets(1).UsedRange
            J = xSaveRg.Rows.Count + 1 + J
            Debug.Print xRg.Address
            xSaveRg.Copy Destination:=xRg
            On Error Resume Next
            xWb.Close False
            
            Set xRg = xSh.Cells(J, 1)
        Next
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
تم تصغير هذا التعليق بواسطة المشرف على الموقع
هذا يعمل بشكل جيد. ولكن عند استيراده ، فإنه يعيد تسمية الأوراق باستخدام name.txt ، كيف تجعله يحتفظ بالاسم فقط دون إضافة امتداد .txt إلى الورقة؟
تقييم شنومك من شنومكس
تم تصغير هذا التعليق بواسطة المشرف على الموقع
طيب nvm وجدت الجواب بمساعدة جوجل.
استبدال الخط:
ActiveSheet.Name = xWb.Name
مع:
ActiveSheet.Name = يسار (xWb.Name ، Len (xWb.Name) -4)
سيزيل آخر 4 أحرف من اسم الورقة. بشكل فعال يعطيني ما احتاجه. اسم بدون .txt
هتاف
تقييم شنومك من شنومكس
تم تصغير هذا التعليق بواسطة المشرف على الموقع
يمكن للكود أدناه تقسيم البيانات إلى أعمدة بناءً على المسافة أو علامة التبويب أثناء استيراد ملف نصي إلى الأوراق. لكنني لا أريد علامة تبويب منفصلة لكل ملف txt أود أن كل منهم في ورقة واحدة. المعلومات هي نفس التنسيق لكل ملف. . ما يمكن تعديله للسماح لهذا أن يكون كل ورقة واحدة بدلاً من أن يكون كل ملف تم استيراده علامة تبويب جديدة وأي مساعدة ستكون موضع تقدير

فرعي ImportTextToExcel ()
'تحديث بواسطةExtendoffice20180911
خافت xWb كمصنف
خافت xToBook كمصنف
خافت xStrPath كسلسلة
خافت xFileDialog كحوار ملف
خافت x ملف كسلسلة
Dim xFiles كمجموعة جديدة
أنا خافت وطويلة
خافت xIntRow وطول
خافت xFNum ، xFArr طويل
خافت xStrValue كسلسلة
خافت xRg كمدى
خافت xArr
قم بتعيين xFileDialog = Application.FileDialog (msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = خطأ
xFileDialog.Title = "حدد مجلدًا [Kutools for Excel]"
إذا كان xFileDialog.Show = -1 ثم
xStrPath = xFileDialog.SelectedItems (1)
إنهاء حالة
إذا كان xStrPath = "" ثم اخرج من Sub
إذا كان صحيحًا (xStrPath، 1) <> "\" ثم xStrPath = xStrPath & "\"
xFile = Dir (xStrPath & "* .txt")
إذا كان xFile = "" إذن
MsgBox "لم يتم العثور على ملفات" ، vbInformation ، "Kutools for Excel"
خروج الفرعية
إنهاء حالة
القيام أثناء xFile <> ""
xFiles.Add xFile ، xFile
xFile = Dir ()
أنشوطة
تعيين xToBook = ThisWorkbook
على خطأ استئناف التالي
Application.ScreenUpdating = خطأ
إذا كان xFiles.Count> 0 ثم

لأني = 1 إلى xFiles.Count
قم بتعيين xWb = Workbooks.Open (xStrPath & xFiles.Item (I))
xWb.Worksheets (1). النسخ بعد: = xToBook.Sheets (xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb إغلاق خطأ
xIntRow = ActiveCell.CurrentRegion.Rows.Count
بالنسبة إلى xFNum = 1 إلى xIntRow
تعيين xRg = ActiveSheet.Range ("A" & xFNum)
xArr = انقسام (xRg.Text، "")
إذا كان UBound (xArr)> 0 ثم
بالنسبة إلى xFArr = 0 إلى UBound (xArr)
إذا كان xArr (xFArr) <> "" ثم
xRg.Value = xArr (xFArr)
تعيين xRg = xRg.Offset (ColumnOffset: = 1)
إنهاء حالة
التالى
إنهاء حالة
التالى
التالى
إنهاء حالة
Application.ScreenUpdating = ترو
نهاية الفرعية
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا دانيال ، جرب الكود أدناه ، فهو يستورد جميع الملفات النصية في ورقة واحدة باسم Txt.
لاحظ أنه: إذا كان اسم النص هو نفسه مع اسم الورقة الخارج ، فقد لا يتم استيراد الملف النصي.
Sub ImportTextToExcel2()

'UpdatebyExtendoffice20230106

Dim xWb As Workbook

Dim xToBook As Workbook

Dim xStrPath As String

Dim xFileDialog As FileDialog

Dim xFile As String

Dim xFiles As New Collection

Dim I As Long

Dim xIntRow As Long

Dim xFNum, xFArr As Long

Dim xStrValue As String

Dim xRg As Range

Dim xArr

Dim xRowL, xRowH As Integer

Dim xTxtWS, xWSD As Worksheet

Dim xTxtWS_Rg As Range

Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

xFileDialog.AllowMultiSelect = False

xFileDialog.Title = "Select a folder [Kutools for Excel]"

If xFileDialog.Show = -1 Then

xStrPath = xFileDialog.SelectedItems(1)

End If

If xStrPath = "" Then Exit Sub

If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"

xFile = Dir(xStrPath & "*.txt")

If xFile = "" Then

MsgBox "No files found", vbInformation, "Kutools for Excel"

Exit Sub

End If

Do While xFile <> ""

xFiles.Add xFile, xFile

xFile = Dir()

Loop

Set xToBook = ThisWorkbook

On Error Resume Next

Set xTxtWS = xToBook.Worksheets("Txt")

If IsNull(xTxtWS) Or IsEmpty(xTxtWS) Then

    Set xTxtWS = xToBook.Worksheets.Add

    xTxtWS.Name = "Txt"

End If

Application.ScreenUpdating = False

Application.DisplayAlerts = False

xTxtWS.Activate

If xFiles.Count > 0 Then

xRowL = 1

For I = 1 To xFiles.Count

Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))

xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

Set xWSD = xToBook.Sheets(xToBook.Sheets.Count)

xTxtWS.Activate

xWb.Close False

xIntRow = xWSD.UsedRange.CurrentRegion.Rows.Count

    For xFNum = 1 To xIntRow

        Set xRg = xWSD.Range("A" & xFNum)

        xArr = Split(xRg.Text, " ")

        Set xTxtWS_Rg = xTxtWS.Cells.Range("A" & xRowL)

'        If UBound(xArr) > 0 Then

            For xFArr = 0 To UBound(xArr)

                If xArr(xFArr) <> "" Then

                xTxtWS_Rg.Value = xArr(xFArr)

                Set xTxtWS_Rg = xTxtWS_Rg.Offset(ColumnOffset:=1)

                End If

            Next

'        End If

xRowL = xRowL + 1

    Next

xWSD.Delete

Next

End If

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub


لا توجد تعليقات منشورة هنا حتى الآن
اترك تعليقاتك
النشر كضيف
×
قيم المنشور:
0   الشخصيات
المواقع المقترحة

تواصل معنا

حقوق التأليف والنشر © 2009 - شبكة الاتصالات العالمية.extendoffice.com. | كل الحقوق محفوظة. مشغل بواسطة ExtendOffice. | | خريطة الموقع
Microsoft وشعار Office هما علامتان تجاريتان أو علامتان تجاريتان مسجلتان لشركة Microsoft Corporation في الولايات المتحدة و / أو دول أخرى.
محمي بواسطة Sectigo SSL