عبدالفتاح في بي اكسيل

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

هذا ليس خطا يعلمك بان الكائن غير موجود تحتاج الى تنشيط اداة calendar من داخل الويندوز حتى تعمل وتظهر

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

اخي اين الملف حتى نعرف المدى والورقة التي ستطبق عليها عالعموم هذا ملف به كود برمجي بمجرد الضغط عليه يتم نسخ المدى بنفس عرض العمود في نفس ورقة العمل Sub width_col() Sheets("sheet1").Range("A1:e50000").Copy With Sheets("sheet1").Range("G1") .PasteSpecial xlPasteColumnWidths .PasteSpecial xlPasteValues, , False, False .PasteSpecial xlPasteFormats, , False, False End With Application.CutCopyMode = False End Sub FORMAT WIDTH‬.xls

تفضل اخي لعله المطلوب Book1 (1).xls

بعد اذن الاساتذة هذ ا كود ديناميكي Sub TransferData() Dim a, b, i&, Dic As Object Set Dic = CreateObject("scripting.dictionary") a = Sheets("Sheet1").[B7].CurrentRegion ReDim b(1 To UBound(a), 1 To 10000) For x = 2 To UBound(a) If Not Dic.exists(a(x, 2)) Then i = i + 1 Dic.Add a(x, 2), i b(1, i) = a(x, 2) End If i = Dic(a(x, 2)) For y = 2 To UBound(b) If IsEmpty(b(y, i)) Then b(y, i) = a(x, 3) Exit For End If Next Next Sheets("Sheet2").[C8].Resize(UBound(b), UBound(b, 2)) = b End Sub POSTING.xls

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

تفضل لعله المطلوب الدوال في العمود g =IFERROR(INDEX(C$4:C$1000;MATCH($F5;$B$4:$B$1000;0));"") في العمود h =IFERROR(INDEX(D$4:D$1000;MATCH($F4;$B$4:$B$1000;0));"") sheet.xlsx

جرب هذا الكود لعله المطلوب Sub SAVESHEETS() With Application .DisplayAlerts = False .ScreenUpdating = False End With For Each sh In ThisWorkbook.Worksheets sh.Copy ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx" ActiveWorkbook.Close False Next With Application .DisplayAlerts = True .ScreenUpdating = True End With End Sub SAVESHEET.xlsm

هذا كود يمكنك الاستعانة به بتحديد اسم الشيت واسم الملف ومكان الملف Sub convert() ThisWorkbook.Worksheets("sheet1").Copy ActiveWorkbook.SaveAs Filename:="C:\aaa\file.csv", FileFormat:=xlCSVWindows End Sub

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

ماذا تقصد بالارقام المتشابهة هل مكررة ام ماذا؟ بحثث في العمود d,c لا يوجد قيم مكررة

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

بعد اذن استاد علي كود بطريقة اخرى انقر على اي قيمة من الخلايا المحددة سيطلع مربع حوار اكتب القيمة وسيتم الاضافة Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim xRtn As Variant If Selection.Count = 1 Then If Not Intersect(Target, Range("c:m")) Is Nothing Then If IsNumeric(Target) And Target <> "" Then xRtn = Application.InputBox("Insert your value please") If xRtn <> False And IsNumeric(xRtn) Then Target.Value = Target + xRtn End If End If End If End If End Sub الصلاة2.xlsm

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

هذه محاولة تفضل لعله ما تريد ملاحظة : لا تضغط الملف مرة اخرى الملف صغير لا يستحق ذلك كما ان التيكست بوكس ارقامه غير منظمة نسقه تجنب لاي خطا بالكود Private Sub listbox1_Click() CheckThis = False If ListBox1.ListIndex = -1 Then MsgBox "Nothing Selected!" Exit Sub End If For i = 1 To 18 Me("TextBox" & i).Text = ListBox1.Column(i - 1) Next CheckThis = True End Sub wdad mtn(tora(v1).xlsm

بعد اذن أستاذ احمد تفضل اخي هذا بالكود بعد كتابة الارقام اضغط على ايقونة العدسة وسيتم جلب البيانات Sub EtaEng() Dim idnum As Variant, b As Object, i As Double Sheet2.Activate idnum = Left(Range("D7").Value, 4) Set b = Sheet1.Columns("b").Find(idnum, lookat:=xlPart, LookIn:=xlValues) If Not b Is Nothing Then 'exists i = b.Row Range("D10").Value = Sheet1.Cells(i, 3) Range("D12").Value = Sheet1.Cells(i, 2) Range("D14").Value = Sheet1.Cells(i, 4) Range("D16").Value = Sheet1.Cells(i, 5) Range("H10").Value = Sheet1.Cells(i, 6) Range("H12").Value = Sheet1.Cells(i, 7) Range("H14").Value = Sheet1.Cells(i, 8) Range("H16").Value = Sheet1.Cells(i, 9) Else MsgBox "هذا الرقم غير موجود", vbExclamation End If End Sub ملاحظة : يمكنك تغيير عدد الارقام كما تشاء من خلال هذا السطر وهو مصمم لاربعة ارقام ويجب ان تكتب الارقام من اليسار الى اليمين كما ترى idnum = Left(Range("D7").Value, 4) كشف_المحتاجين_2.xlsm

في محرر الاكواد اضغط alt+ f11 ثم ادراج موديل جديد ثم لصق

جرب هذا الكود Sub abdelfatta() Dim Ary As Variant Dim r As Long, c As Long Ary = Range("A4").CurrentRegion.Value2 With CreateObject("scripting.dictionary") For r = 1 To UBound(Ary) For c = 1 To UBound(Ary, 2) .Item(Ary(r, c)) = .Item(Ary(r, c)) + 1 Next c Next r Range("E4").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .items)) End With End Sub الاكواد شغالة معي ملفك هو فيه مشكلة جرب تصميم ملف اخر

تفضل اخي هذا بالكود ولكن ليس سريع لضخامة بياناتك EURUSD1440 (1).xlsm

كود رائع اخي الرائد احسن ما فيه يهمل الصفوف الفارغة

تفضل لعله المطلوب Sub SaveRange() Dim saveLocation As String Dim rng As Range saveLocation = "C:\Users\سبحان الله\desktop\" & Range("B2").Value & ".pdf" Set rng = Sheets("ورقة1").Range("A1:c12") rng.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=saveLocation, OpenAfterPublish:=True End Sub جدول متغيير1.xlsm

بعد ادن استاد ابراهيم يتم وضع الكود في حدث change لورقة العمل حتى يعمل مباشرة من غير تشغيل الماكرو في كل مرة يتم فيها اختيار اسم Private Sub Worksheet_Change(ByVal Target As Range) i = 2 Do While 1000 x = Cells(i, 1) If x = Range("A1") Then Cells(i, 1).Select Exit Do End If i = i + 1 Loop End Sub

تم ربط الازرار بالاكواد البرنامج يعمل ولكن هناك ملاحظة يوجد كود وهو اخر كود اسمه copy من المفترض ان يكون هناك زر خاص به ولديك خطا فيه محدد صفحة اسمها result وهي غير موجودة في ورقة العمل بصراحة لا اعلم الية عمل البرنامج جربه واعطيني ملاحظاتك النقاط.xlsm

مرحبا بك في هذا المنتدى ان شاء الله تستفيد وتفيد غيرك