هل تريد الاحتفاظ بالمسافة (المحددات) بعد تحويل الملفات النصية إلى أوراق؟

هل يمكنك تحميل الملف النصي والنتيجة التي تريدها بالنسبة لي؟

مرحبًا و 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 = ترو
نهاية الفرعية

يمكنك استخدام Find and Replace fuctuon لاستبدال الفاصلة بمسافة أولاً ، وتطبيق إحدى الطرق المذكورة أعلاه لتحويلها إلى ملف Excel.

هل تقصد دمج كل الملفات النصية في ورقة واحدة؟

مرحبًا ، 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 التي تم استيرادها ليتم لصقها في الورقة 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 إغلاق خطأ
التالى
إنهاء حالة
نهاية الفرعية

آسف ، يدي مقيدتان

عذرًا ، قاسي ، فقط كن حذرًا لتجنب تكرار الاستيراد.

Pooja ، يمكنك تجربة وظيفة Remove Leading Zeros من Kutools for Excel لإزالة جميع الأصفار البادئة من التحديد بعد الاستيراد.

إذا كنت تريد الاحتفاظ بالأصفار البادئة ، فيمكنك تنسيقها كتنسيق نصي بواسطة تنسيق الخلية.

مرحبا ، يرجى المحاولة أدناه الرمز

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

مرحبًا دانيال ، جرب الكود أدناه ، فهو يستورد جميع الملفات النصية في ورقة واحدة باسم 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