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

السلام عليكم استبدل الدالة الموجوده بالفورم ListData بالدالة ادناه علشان بيانات الفورم للاسماء والتواريخ توخذ من جميع الاوراق Function ListData(col As String) Dim d, N Set d = CreateObject("Scripting.Dictionary") Dim Rng As Range, cel As Range ''''''''''''''''''''''''''''' For Each N In Array("مشتريات", "مبيعات", "م.مشتريات", "م.مبيعات", "خزينة") With Sheets(CStr(N)) Set Rng = Range(.Cells(5, col), .Cells(Rows.Count, col).End(xlUp)) '''''''''''''''''''''''' On Error Resume Next For Each cel In Rng d.Add cel.Value, CStr(cel) Next On Error GoTo 0 ''''''''''''''''''''''' End With Next ''''''''''''''''''''''' ListData = d.items Set d = Nothing Set Rng = Nothing End Function هذا بعجل

السلام عليكم بارك الله فيك اخي الحبيب رجب و حفظك من كل مكروه احسنت عملا تقبل تحياتي وشكري

السلام عليكم شاهد المرفق بيانات الفورم للاسماء والتواريخ توخذ من ورقة المشتريات يمكنك تغييرها الى الورقة التي تشمل اغلب البيانات المرفق 2003 -2007 تقرير من عدة اوراق.rar

السلام عليكم بارك الله فيك اخي الحبيب رجب احسنت عملا هذه فقط زيادة معلومات لا غير معلومة: 1 المتغير الافتراضي delimiter للدلة Split مسافة واحدة (" ") يعني الاستخدام هكذا بدون اضافة المتغير newsplit = Split(cl) معلومة: 2 بامكانك اختصار امر اضافة اجزاء الاسم بسطر واحد cl.Offset(0, 1).Resize(1, UBound(newsplit) + 1).Value = newsplit اضافة التغييرات الى الدالة Sub ragab() Dim newsplit Dim cl As Range Dim LR As Long '============================================ LR = [A1000].End(xlUp).Row '============================================ For Each cl In Range("A2:A" & LR).Cells newsplit = Split(Application.Trim(cl)) cl.Offset(0, 1).Resize(1, UBound(newsplit) + 1).Value = newsplit Next End Sub تقبل تحياتي وشكري

السلام عليكم جزاك الله خيرا تقبل تحياتي وشكري

لا املك من الكلمات لتعبر عن امتناني لهذا الكلام الطيب جزاك الله خيرا واكرمك في الدارين وازال عنكم الغمة تقبل تحياتي وشكري

جزاكم الله خيرا تقبلوا تحياتي وشكري

جزاك الله خيرا تقبل تحياتي وشكري

جزاك الله خيرا تقبل تحياتي وشكري

السلام عليكم الدمج يسبب تعارض مع الاكواد والمعادلات في كثير من الاحوال الحل بيدك اخي الفاضل بازالة الدمج لتنتهي المشكلة تقبل تحياتي وشكري

جزاك الله خيرا بالنسبة لاستفسارك راجع الاكود التالية كود للاستيراد وكود للتصدير 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 تقبل تحياتي وشكري

جزاك الله خيرا اخي الحبيب ابوحنين تقبل تحياتي وشكري

السلام عليكم تسمية النطاق ليس صحيحا الكود بعد التصحيح 'كود زر للتنقل بين الشيتات باسماء غير أسمائها '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Option Explicit Const mBr As String = "MySheetList" Sub kh_AddName() Dim Nam As Range Dim i As Integer Dim NamSheet As String ''''''''''''''''''''''''''''''' On Error GoTo kh_Err ''''''''''''''''''''''''''''''' kh_BarDelete ''''''''''''''''''''''''''''''' Set Nam = ورقة32.Range("E2:AH3") ''''''''''''''''''''''''''''''' With Application.CommandBars.Add(Name:=mBr, Position:=msoBarPopup) For i = 1 To Nam.Columns.Count NamSheet = Nam.Cells(2, i) With .Controls.Add(Type:=msoControlButton) .Caption = Nam.Cells(1, i) .OnAction = "GO_MySheet" .Tag = NamSheet If NamSheet = ActiveSheet.Name Then .State = -1 If IsError(Evaluate("'" & NamSheet & "'!A1")) Then .Enabled = False End If End With Next End With ''''''''''''''''''''''''''''''' Application.CommandBars(mBr).ShowPopup ''''''''''''''''''''''''''''''' kh_Err: Set Nam = Nothing If Err Then MsgBox "Err.Number : " & Err.Number kh_BarDelete End Sub Sub kh_BarDelete() On Error Resume Next Application.CommandBars(mBr).Delete On Error GoTo 0 End Sub Sub GO_MySheet() Dim N As String On Error Resume Next N = Application.CommandBars.ActionControl.Tag Sheets(N).Activate End Sub

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

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

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

يمكنك تجاوز هذا العمود عند تعيينك للنطاق في كود اظهار الفورم Sub kh_Show_UFormChang2() On Error GoTo 1 With UFormChang .kh_SetAddrss "مثال2", "C4:D4,F4:H4", "B4" .Show End With 1: If Err Then MsgBox "تاكد من صحة ادخال المتغيرات الاساسية في : " & vbCr & vbCr & "kh_SetAddrss", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "استخدام خاطىء" On Error GoTo 0 End Sub

لا ادري ايش المشكلة عندكم سننتظر اذا اشتكى احدهم من نفس الكود سنعرف ان المشكلة ليست خاصة بك فقط تقبل تحياتي وشكري

كل عام وانتم بخير جزاك الله خيرا تقبلوا تحياتي وشكري

السلام عليكم ورحمة الله وبركاته تقبل الله منا ومنكم وجعلنا ممن ينظر اليهم الرحمن فيقول ( اذهبوا مغفور لكم ) نورت المنتدى اخي الفاضل هشام كيف صحتكم الان ان شاء الله تكونوا في صحة وعافية وكل عام وانتم بخير

السلام عليكم شاهد الحل في هذا الموضوع http://www.officena.net/ib/index.php?showtopic=43828

السلام عليكم ورحمة الله وبركاته استيراد اسطر معينة من ملف نصي (مفكرة) بدلالة كلمات موجودة في اسطر الملف النصي وهو طلب لاحدهم جعلته هنا لتعم الفائدة 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_2007 استيراد قيم من ملف نص.rar

السلام عليكم بارك الله فيكم الجمع المبارك وكل عام وانتم بخير ===================== لاثراء الموضوع : الدالة ادناه يمكنك استخدامها مهما كان عدد الارقام المضافة واي طول للرقم مثلا: =12+1222+111 =12345+1222 عين تسلسل الرقم المضاف في المتغير iNdx 1 للقيمة الاولى , 2 للقيمة الثانية , 3 للقيمة الثالثة .... وهكذا =kh_ShowValue($D$2;1) كود الدالة: Function kh_ShowValue(RngFormla As Range, iNdx As Integer) Dim sFm As String sFm = Mid$(RngFormla.Formula, 2) kh_ShowValue = Split(sFm, "+")(iNdx - 1) End Function تقبلوا تحياتي وشكري

السلام عليكم هذه الامكانية غفلنا عن ذكرها : 8 - بامكانك انتقاء الاعمدة التي تريدها عند تسمية النطاق وترتيبها حسب ما تريد مع ملاحظة ان العمود الذي يعتمد عليه في احتساب آخر صف هو العمود الاول من التسمية مثلا: "E15,C15,H15:AX15" اول عمود هو E