حسين مامون

بعد اذن استاد طارق محمود ولاثراء الموضوع جرب المرفق 1 انسخ المجلد المسمى mydata في :d 2 افتح الملف المسمى main واضغط زر استعلام سيأتي ببيانات حسب الرقم في العمود A ملاحظة تم تغيير اسماء الشيتات ليعمل الكود بكفاءة ارجو ان يكون ما تريد my data.rar

سلمت اناملك استاذ سليم ربنا يجعله في ميزان حسناتك تحياتي

تقرير 8.xlsm

اليك المرفق تقرير 8.xlsm Private Sub CommandButton1_Click() Application.ScreenUpdating = False Dim SH As Worksheet Set SH = Sheets("ورقة1") Dim rr, lr, x, m Range("b5:i10000").ClearContents rr = Cells(Rows.Count, 1).End(xlUp).Row lr = SH.Cells(Rows.Count, 1).End(xlUp).Row For m = 5 To rr If Cells(m, 1).Text = "" Then Exit Sub For x = 2 To lr If Cells(m, 1).Text = SH.Cells(x, 1).Text Then Cells(m, 1).Select With Sheets("sheet1") .Cells(m, 2).Resize(1, 115).Value = SH.Cells(x, 2).Resize(1, 115).Value End With End If Next Next Application.ScreenUpdating = True End Sub

اليس الملف الذي قمت بتحميله نمودج عن الملف المعني

جرب الطريقة دي تقرير.xlsm

بعد اذن استاذي سليم جرب المرفق تمنى ان يكون ما تتمناه تقرير.xlsm

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

تفضل ربط القائمة المنسدلة مع زر الاوبشن.xlsm

افتح الملف واغلق الفورم وافتح ملف اخر محفوظ بامتداد xlsm واضغط Alt+f11 وستجد الملفين ثم ادخل الى thisworkbook وعدل الكود

الحمد لله ان تم الامر كما تريد

اتمنى ان يكون ما تريد في المرفق واعتذر تجربة (2) (2).xlsm

وجزيت خيرا اخي

جرب المرفق قمت باضافة تصميم اخر في ورقة1 لان تصميمك فيه خلايا مدمجة ان اعجبك ذلك يمكنك العمل عليه هناك كودين واحد لمنع الترحيل عند عدم اكمال البيانات في الصف والثاني للترحيل والافراغ المحتويات تحياتي تجربة (2).xlsm

جرب هذا الماكرو Option Explicit Sub test_mamoun() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim lr1, lr2, x Application.ScreenUpdating = False Set sh1 = Sheets("ترحيل مصروفات") Set sh2 = Sheets("مصروفات") For x = 7 To 17 If sh1.Cells(x, "b") = "" Then go to 1 lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh2.Range("a" & lr2).Resize(1, 3).Value = sh1.Cells(x, "b").Resize(1, 3).Value sh2.Range("d" & lr2).Value = sh1.Cells(x, "f").Value sh2.Range("f" & lr2).Value = sh1.Cells(x, "o").Value sh2.Range("g" & lr2).Value = sh1.Cells(x, "q").Value sh2.Range("h" & lr2).Value = sh1.Cells(x, "s").Value sh2.Range("i" & lr2).Value = sh1.Cells(x, "v").Value sh2.Range("j" & lr2).Value = sh1.[l2] sh2.Range("k" & lr2).Value = sh1.Cells(x, "y").Value 1:Next Application.ScreenUpdating = True End Sub

يمكنك استعمال هذا الماكرو البسيط انسخه الى مديول واربططه بزر في شيت sadol1 Option Explicit Sub test() Dim SD1 As Worksheet Dim SD2 As Worksheet Dim lr1, lr2, lr3, lr4 Application.ScreenUpdating = False Set SD1 = Sheets("sadok1") Set SD2 = Sheets("sadok2") lr1 = SD1.Cells(Rows.Count, "b").End(3).Row lr2 = SD1.Cells(Rows.Count, "s").End(3).Row SD1.Range("b8:o" & lr1).Copy lr3 = SD2.Cells(Rows.Count, "b").End(3).Row + 1 SD2.Range("b" & lr3).PasteSpecial SD1.Range("s8:af" & lr2).Copy lr4 = SD2.Cells(Rows.Count, "s").End(3).Row + 1 SD2.Range("s" & lr4).PasteSpecial Application.CutCopyMode = False SD1.Range("b8:o10000").ClearContents SD1.Range("s8:af10000").ClearContents Application.ScreenUpdating = True End Sub

جرب المرفق fathy www.xlsm

بارك الله فيك استاذي سليم عمل رائع

بعد اذن استاذي الكريم Ali Mohamed Ali جرب الكود Sub testttttttttt() Dim x, y Dim lr Application.ScreenUpdating = False lr = Cells(Rows.Count, "e").End(3).Row For x = 3 To lr For y = 6 To 100 If Cells(x, "e").Text = Cells(2, y) Then Cells(x, y).Value = Cells(x, "d").Value End If Next Next Application.ScreenUpdating = True End Sub

غير اسم الملف الى ما تريد ولكن سيضيف للاسم تاريخ وساعة الحفظ وسيظهر هكذا مثلا

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

عليكم السلام جرب المرفق فيه كود انشاء مجلد في :D وهذا ان لم يجده اسم المجلد myDOSER ويحول المدى المحدد في الكود الى PDF TEST .xls

جزاك الله خيرا وزادك من فضله استاذ احمد بدره

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

جرب التعديل المستخدم asd كلمة السر 123 login __ (1).xlsm