استيراد اسطر معينة من ملف نصي (مفكرة)

[عبدالله باقشير]

السلام عليكم ورحمة الله وبركاته

استيراد اسطر معينة من ملف نصي (مفكرة)

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

وهو طلب لاحدهم جعلته هنا لتعم الفائدة

http://www.officena....showtopic=43791


الكود :

 

Option Explicit
'''''''''''''''

' اسم ملف النص
Const tName As String = "QQQ.txt"
'''''''''''''''''''''''''''''''
' كلمة البحث عن سطر الكود كما هي في ملف النص
Const S1 As String = "كود:"
'''''''''''''''''''''''''''''''
' كلمة البحث عن سطر الاجمالي كما هي في ملف النص
Const S2 As String = "الأجــمــالي"
'''''''''''''''''''''''''''''''

Sub kh_Import_Lines_of_TextFile()
Dim MySplit
Dim MyFile As String, MyText As String
Dim iRow As Long
'=============================
' مسح محتويات الجدول
Range("A3:F14").ClearContents
'''''''''''''''''''''''''''''''
' tName الاسم الكامل لملف النص الموجود في مسار ملف الاكسل والذي تم تعيين اسمه في الثابت
MyFile = ThisWorkbook.Path & ThisWorkbook.Application.PathSeparator & tName
'''''''''''''''''''''''''''''''
' اول صف لنقل البيانات
iRow = 3
'=============================
Application.ScreenUpdating = False
'=============================
Open MyFile For Input Access Read As #1
'=============================
While Not EOF(1)
Line Input #1, MyText
'''''''''''''''
' S1 اذا كان يحتوي السطر على الكلمة المعينة في الثابت
If InStr(MyText, S1) Then
' معالجة السطر لاعطائنا الرقم فقط
MyText = Mid$(MyText, InStr(MyText, S1))
MyText = Replace(MyText, S1, "")
MyText = WorksheetFunction.Trim(MyText)
Range("A" & iRow).Value = MyText
End If
'''''''''''''''''''''''
' S2 اذا كان يحتوي السطر على الكلمة المعينة في الثابت
If InStr(MyText, S2) Then
' معالجة السطر وتحويله الى اعمدة بالنص الرقمي المطلوب
MyText = Replace(MyText, S2, "")
MyText = WorksheetFunction.Trim(MyText)
MySplit = Split(MyText)
With Range("B" & iRow).Resize(1, UBound(MySplit) + 1)
.Value = MySplit
' تحويل النص الرقمي في الخلية الى رقم
.Replace ",", "."
End With
iRow = iRow + 1
End If
'''''''''''''''''''''''
Wend
Close #1
'=============================
Application.ScreenUpdating = True
'=============================

End Sub

المرفق ملف اكسل 2003-2007
ملف نصي + صورة
استيراد اسطر معينة من ملف نصي.rar

===========================================
المرفق الثاني
امثلة لاستيراد وتصدير
لجدول بيانات مرتب

 

Dim MyCode As Double, MyCur As String, MyDate As Date


Sub ExportRange()
Dim r As Integer
    
Open ThisWorkbook.Path & "\textfile.txt" For Output As #1
'''''''''''''''''''''
Do
    r = r + 1
    With Range("B6")
        If Len(Trim(.Cells(r, 1))) = 0 Then Exit Do
        MyCode = .Cells(r, 1)
        MyCur = .Cells(r, 2)
        MyDate = .Cells(r, 3)
    End With
    '''''''''''''''''''''
    Write #1, MyCode, MyCur, MyDate
    '''''''''''''''''''''
Loop
'''''''''''''''''''''
Close #1
'''''''''''''''''''''
End Sub
Sub ImportRange()
Dim i As Integer

Range("B6").Resize(1000, 3).ClearContents
On Error GoTo 1
Open ThisWorkbook.Path & "\textfile.txt" For Input As #1
    
While Not EOF(1)
    Input #1, MyCode, MyCur, MyDate
    i = i + 1
    '''''''''''''''''''''
    With Range("B6")
        .Cells(i, 1) = MyCode
        .Cells(i, 2) = MyCur
        .Cells(i, 3) = MyDate
    End With
    ''''''''''''''''''''
Wend
Close #1
1:
End Sub

المرفق ملف اكسل 2003-2007
استيراد تصدير.rar

[سمير هنداوي]

بارك الله فيك أخونا العزيز عبد الله باقشير

[سمير هنداوي]

فعلا رأيت الملف أنت أستاذ و رئيس قسم بارك الله فيك أخي العزيز

تقبل تحيتي و سلامي

[اوفيس 2003]

ياسلالالالام عليك يا استاذنا ، والله هذا مااريد بالفعل ،ولكن محتاج وقت كبير لأتعلمه يا استاذنا دعواتك لي ، لي سؤال على السريع ياغالي فرضا ان الملف النصي المرفق ده اكبر في الحجــم واكثر في البيانات هل ممكن ان اصممه ليظهر هذه النتائج ياغالي

وياريت لو ترفقلي الكود بدون الشرح ايضا ياغالي

ويعد اذنك اريد ان ارسلك شيء خاص جدا في عملي على الخاص فبرجاء اسمحلي بالإرسال لأنه يرفض تماماً

تم تعديل أكتوبر 30, 2012 بواسطه office 2003

[عبدالله باقشير]

فعلا رأيت الملف أنت أستاذ و رئيس قسم بارك الله فيك أخي العزيز

تقبل تحيتي و سلامي

جزاك الله خيرا

[عبدالله باقشير]

ياسلالالالام عليك يا استاذنا ، والله هذا مااريد بالفعل ،ولكن محتاج وقت كبير لأتعلمه يا استاذنا دعواتك لي ، لي سؤال على السريع ياغالي فرضا ان الملف النصي المرفق ده اكبر في الحجــم واكثر في البيانات هل ممكن ان اصممه ليظهر هذه النتائج ياغالي

وياريت لو ترفقلي الكود بدون الشرح ايضا ياغالي

ويعد اذنك اريد ان ارسلك شيء خاص جدا في عملي على الخاص فبرجاء اسمحلي بالإرسال لأنه يرفض تماماً

فرضا ان الملف النصي المرفق ده اكبر في الحجــم واكثر في البيانات هل ممكن ان اصممه ليظهر هذه النتائج ياغالي

جرب الكود بنفسك

على اي ملف نصي فيه بيانات اكثر بنفس معايير الملف النصي الحالي

وابعد صف المجاميع في الورقة

واخبرنا بالنتائج

للمراسلة اضغط الصورة اللي فيها اسمي

في توقيعي

[أبو حنــــين]

بارك الله فيكم أخي الحبيب : عبد الله

جزاكم الله خيرا

عمل متقن فعلا

[أنس دروبي]

السلام عليكم ورحمة الله وبركاته

الله يجزيك الخير أستاذي عبد الله باقشير

والله أنه عمل متقن ومبدع من استاذ محترف

ولكن أستاذي لو أفترضنا أننا نريد العكس وهي التصدير من ملف إكسل الى ملف نصي أو صفحة ويب ولكن في تنسيق معين

فهل يصح ذلك وفي نفس الوقت الاستيراد من هذا الملف النصي

مثل نسخة أحتياطية قابلة للاستراجع

والسلام عليكم ورحمة الله وبركاته

تقبل مروري وتحياتي

أخوكم أنس دروبي

[عبدالله باقشير]

بارك الله فيكم أخي الحبيب : عبد الله

جزاكم الله خيرا

عمل متقن فعلا

جزاك الله خيرا

اخي الحبيب ابوحنين

تقبل تحياتي وشكري

[عبدالله باقشير]

السلام عليكم ورحمة الله وبركاته

الله يجزيك الخير أستاذي عبد الله باقشير

والله أنه عمل متقن ومبدع من استاذ محترف

ولكن أستاذي لو أفترضنا أننا نريد العكس وهي التصدير من ملف إكسل الى ملف نصي أو صفحة ويب ولكن في تنسيق معين

فهل يصح ذلك وفي نفس الوقت الاستيراد من هذا الملف النصي

مثل نسخة أحتياطية قابلة للاستراجع

والسلام عليكم ورحمة الله وبركاته

تقبل مروري وتحياتي

أخوكم أنس دروبي

جزاك الله خيرا

بالنسبة لاستفسارك

راجع الاكود التالية

كود للاستيراد وكود للتصدير

Dim MyCode As Double, MyCur As String, MyDate As Date



Sub ExportRange()

Dim r As Integer


Open ThisWorkbook.Path & "\textfile.txt" For Output As #1

'''''''''''''''''''''

Do

r = r + 1

With Range("B6")

If Len(Trim(.Cells(r, 1))) = 0 Then Exit Do

MyCode = .Cells(r, 1)

MyCur = .Cells(r, 2)

MyDate = .Cells(r, 3)

End With

'''''''''''''''''''''

Write #1, MyCode, MyCur, MyDate

'''''''''''''''''''''

Loop

'''''''''''''''''''''

Close #1

'''''''''''''''''''''

End Sub

Sub ImportRange()

Dim i As Integer


Range("B6").Resize(1000, 3).ClearContents

On Error GoTo 1

Open ThisWorkbook.Path & "\textfile.txt" For Input As #1


While Not EOF(1)

Input #1, MyCode, MyCur, MyDate

i = i + 1

'''''''''''''''''''''

With Range("B6")

.Cells(i, 1) = MyCode

.Cells(i, 2) = MyCur

.Cells(i, 3) = MyDate

End With

''''''''''''''''''''

Wend

Close #1

1:

End Sub

المرفق 2003-2007

استيراد تصدير.rar

تقبل تحياتي وشكري

[قصي]

العلامة الكبير عبد الله بارك الله فيكم وبكم وسدد الله خطاكم وعافاكم من كل سوء

[abouelhassan]

والله كل الاحترام روائع استاذنا

بارك الله فيك