كيف يمكنني البحث عن سلسلة باستخدام إدخال الخط ثم طباعة الأسطر 5 التالية في خلية إكسيل

Question

كيف يمكنني البحث عن سلسلة, ثم عندما يتم العثور على سلسلة, كتابة السطر بأكمله حيث تم العثور على سلسلة, ثم الأسطر الخمسة التالية في نفس الخلية في إكسيل باستخدام فبا?

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

لا يحدث هذا الشرط لجميع القيم ، فقط تلك التي تحتوي على فواصل أسطر مثل هذه:

    How To Fix: To remove this functionality, set the following Registry key settings:
    Hive: HKEY_LOCAL_MACHINE
    Path: System\CurrentControlSet\Services...
    Key: SomeKey
    Type: DWORD
    Value: SomeValue
    Related Links: Some URL

أحاول الحصول على كل شيء من How to Fix:... إلى Value:... للكتابة إلى ورقة إكسيل بلدي، في نفس الخلية جنبا إلى جنب مع البيانات الموجودة على How to fix:... خط.

وأنا أعلم أن Input Line يتوقف تلقائيا عند فواصل الأسطر وينتقل إلى السطر التالي.التي ، ث / س بلدي loop محاولات ، هو ما يفعله الرمز أدناه.

 If InStr(inputline, "How to Fix:") <> 0 Then
    'Do While Not InStr(inputline, "Related Links:")
    ' Get rid of special characters in string
       For i = 1 To Len(description)
            sletter = Mid(description, i, i + 1)
            iasc = Asc(sletter)
           If Not (iasc <= 153 And iasc >= 32) Then
                  description = Left(description, i - 1) & " " & Right(description, Len(description) - i)
           ' End If

       'Next
       Do Until InStr(inputline, "Related Links:") = 1
            description = Replace(description, "How to Fix:", "")
            ws.Cells(rowndx4, 7).Value = Trim(description)
        Loop
End If

حاولت أيضا استخدام FileSystemObject لكنه لا يطبع أي شيء إلى ورقة عمل إكسيل.الرمز أدناه:

Private Function ScanFile2$(FileToRead2 As String, rowndx4 As Long)

Dim wb As Workbook, ws As Worksheet, i As Long
Dim FNum3 As Integer, inputline As String, whatfile As Integer, testnum As String
Dim description As String
Dim finding As String

Set ws = ActiveWorkbook.Worksheets("Sheet1")
    FNum3 = FreeFile()

Dim oFSO As FileSystemObject
Set oFSO = New FileSystemObject
Dim TS As TextStream
Const ForReading = 1
Set TS = oFSO.OpenTextFile(FNum3, ForReading)

Do While TS.AtEndOfStream <> True
inputline = TS.ReadAll
description = inputline

If InStr(inputline, "How To Fix:") <> 0 Then
            description = Replace(inputline, "How To Fix:", "")
            ws.Cells(rowndx4, 2).Value = inputline
End If
Exit Do
Loop
Close FNum3
Set ws = Nothing        
Application.ScreenUpdating = True
ScanFile2 = rowndx4
End Function

Answer 1

هذا الرمز

• يستخدم RegExp لإزالة فواصل الخطوط (استبدال مع |) لشد ثم سلسلة
• ثم يستخرج كل مباراة مع ثانية RegExp

تغيير مسار الملف الخاص بك هنا c:\temo\test.txt

عينة المدخلات والمخرجات في القاع

كود

Sub GetText()

Dim objFSO As Object
Dim objTF As Object
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Dim strIn As String
Dim strOut As String
Dim lngCnt As Long

Set objRegex = CreateObject("vbscript.regexp")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objts = objFSO.OpenTextFile("c:\temp\test.txt")

strIn = objts.readall

With objRegex
.Pattern = "\r\n"
.Global = True
.ignorecase = True
strOut = .Replace(strIn, "|")
.Pattern = "(How to Fix.+?)Related"
Set objRegMC = .Execute(strOut)
For Each objRegM In objRegMC
lngCnt = lngCnt + 1
Cells(lngCnt, 7) = Replace(objRegM.submatches(0), "|", Chr(10))
Next
End With

End Sub

المدخلات

اختبار كيفية إصلاح:لإزالة هذه الوظيفة ، قم بتعيين إعدادات مفتاح التسجيل التالية:
خلية:هكي _ المحلي_آلة
المسار:النظام \ كيرنتكونترولسيت \ الخدمات...
مفتاح:سوميكي
النوع:دورد
القيمة:بعضالقيمة
روابط ذات صلة:بعض رابط أخرى
كيفية إصلاح:لإزالة هذه الوظيفة ، قم بتعيين إعدادات مفتاح التسجيل التالية:
خلية:هكي _ المحلي_آلة المسار:النظام \ كيرنتكونترولسيت \ الخدمات...
مفتاح:سوميكي
النوع:دورد
القيمة:سوميفالوي2
روابط ذات صلة:بعض URL 2

الناتج

Answer 2

وهنا رمز كامل

  Sub test()
  ' Open the text file
    Workbooks.OpenText Filename:="C:\Excel\test.txt"

  ' Select the range to copy and copy
    Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Copy

  ' Assign the text to a variable
    Set my_object = CreateObject("htmlfile")
    my_var = my_object.ParentWindow.ClipboardData.GetData("text")
  ' MsgBox (my_var)   ' just used for testing
    Set my_object = Nothing

    pos_1 = InStr(1, my_var, "How to fix:", vbTextCompare)
    pos_2 = InStr(pos_1, my_var, "Related Links", vbTextCompare)
    my_txt = Mid(my_var, pos_1, -1 + pos_2 - pos_1)

  ' Return to the original file and paste the data
    Windows("stackoverflow.xls").Activate
    Range("A1") = my_txt

  ' Empty the clipboard
    Application.CutCopyMode = False
  End Sub

هذا يعمل بالنسبة لي...

أولا ، تعيين النص في ملف نصي إلى متغير (مي_فار في المثال أدناه)

  pos_1 = InStr(1, my_var, "How to fix:", vbTextCompare)
  pos_2 = InStr(pos_1, my_var, "Related Links", vbTextCompare)
  my_txt = Mid(my_var, pos_1, -1 + pos_2 - pos_1)
  Range("wherever you want to put it") = my_txt

يمكنك أيضا تنظيف النص الخاص بي باستخدام وظيفة" استبدال " إذا أردت.