احمدزمان

السلام عليكم و رحمة الله وبركاته
Sub فاتورة_بيع_للمخزن() ' ' فاتورة_بيع_للمخزن ماكرو ' Dim FS As Worksheet, TS As Worksheet Dim Q1 Set FS = Sheets(ActiveSheet.Name) Set TS = Sheets("المخزن") For FR = 5 To 69 Q1 = FS.Cells(FR, 5).Value Q3 = FS.Cells(FR, 8).Value For TR = 1 To 999 If TS.Cells(TR, 1) = Q1 Then TS.Cells(TR, 3) = TS.Cells(TR, 3) - Q3 GoTo 9 End If Next 'TR 9 Next ' FR ' End Sub Sub فاتورة_مورد_للمخزن() ' ' فاتورة_بيع_للمخزن ماكرو ' Dim FS As Worksheet, TS As Worksheet Dim Q1 Set FS = Sheets(ActiveSheet.Name) Set TS = Sheets("المخزن") For FR = 5 To 69 Q1 = FS.Cells(FR, 5).Value Q3 = FS.Cells(FR, 8).Value For TR = 1 To 999 If TS.Cells(TR, 1) = Q1 Then TS.Cells(TR, 3) = TS.Cells(TR, 3) - Q3 GoTo 9 End If Next 'TR 9 Next ' FR ' End Sub  

السلام عليكم و رحمة الله وبركاته
 
تم عمل المطلوب 
مع رسالة عند تكرار الاسم
Sub az_mokhtar() 'äÞá ÇáÈíÇäÇÊ Dim WB1 As Workbook, WB2 As Workbook Dim FS As Worksheet, TS As Worksheet Dim Q1, Q2, TR, TR2 Set WB1 = Workbooks(ActiveWorkbook.Name) Set FS = WB1.Sheets(ActiveSheet.Name) Q1 = FS.Range("J2").Text Workbooks.Open (Q1) 'Workbooks.Open "C:\Users\Ad\Desktop\ãÎÊÇÑ\mokhtar4 (1).xls" Set WB2 = Workbooks(ActiveWorkbook.Name) Set TS = WB2.Sheets(1) TR = TS.[a65536].End(xlUp).Row + 1 '' Q2 = FS.Cells(1, 2).Text For TR2 = 2 To TR If TS.Cells(TR2, 1) = Q2 Then MsgBox "ãæÌæÏ: " & Q2 & " - - ÕÝ= " & TR2 TR = TR2 GoTo 7 End If Next '' 7 TS.Cells(TR, 1) = FS.Cells(1, 2) TS.Cells(TR, 2) = FS.Cells(2, 3) TS.Cells(TR, 3) = FS.Cells(5, 4) TS.Cells(TR, 4) = FS.Cells(3, 3) TS.Cells(TR, 5) = FS.Cells(4, 3) TS.Cells(TR, 6) = FS.Cells(5, 3) TS.Cells(TR, 7) = FS.Cells(1, 7) TS.Cells(TR, 8) = FS.Cells(2, 7) WB2.Save WB2.Close FS.Activate End Sub شاهد المرفق 
مع التحية
مختار.rar

العفو
جزاك الله خيرا

نفس الكود السابق
انسخة ثم الصقه ثم غير اسم الكود 
ثم
علامة + الوحيدة الموجودة في الكود استبدلها الى - 
ثم اربط الكود بزر الفاتورة للبيع .... مرفق ملف
المخزنAZ02.xlsm

و عليكم السلام و رحمة الله وبركاته
يجب تغيير اسماء الاوراق بما يتطابق تماما مع اسماء الاعمدة
لكي يتم وضع كل بند في ورقته
الكود موجود في حدث التغيير في الورقة
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 4 And Target.Column >= 4 _ And Target.Column < 20 Then For Q1 = 3 To Sheets.Count If Sheets(Q1).Name = Cells(3, Target.Column).Text _ Then GoTo 8 Next MsgBox "Nun" & Cells(3, Target.Column).Text GoTo 9 8 Set TS = Sheets(Cells(3, Target.Column).Text) Q1 = Cells(Target.Row, 22).Text Q2 = Cells(Target.Row, Target.Column).Value With TS For TR1 = 8 To 99 If .Cells(TR1, 5) = Q1 Then .Cells(TR1, 3) = Q2 GoTo 9 End If Next For TR2 = 8 To 99 If .Cells(TR2, 5) = "" Then .Cells(TR2, 5) = Q1 .Cells(TR2, 3) = Q2 GoTo 9 End If Next End With End If 9 End Sub مرفق الملف
مع التحية
اداري تعديل.xls

هذه مشكلة في الادخال 
حيث يتم ادخال الوقت بطريقة غير صحيحة
لادخال الوقت يجب استخدام (  :  ) وليس الفاصلة العشرية
بمعنى عندما تريد ادخال 21 دقيقة
تكتب هكذا
00:21
و ليس هكذا
0.21
مع التحية
 

السلام عليكم و رحمة الله وبركاته
اخي الفاضل
استخدم الدالة التالية
=HYPERLINK(CONCATENATE("#";ADDRESS(ROW();7;;;$E$1))) و اسحبها الى الاسفل
ان شاء الله
سوف تعمل معك كما فهمت من طلبك
مع التحية
 

السلام عليكم و رحمة الله وبركاته
ابحث عن برنامج اسمه
EXCEL RECAVERY
هو مختص باصلاح برامج الاكسل
لم اجد له سابقا اي نسخ مجانية
 

السلام عليكم و رحمة الله وبركاته
اخي الفاضل
استخدم الدالة التالية
=HYPERLINK(CONCATENATE("#";ADDRESS(ROW();7;;;$E$1))) و اسحبها الى الاسفل
ان شاء الله
سوف تعمل معك كما فهمت من طلبك
مع التحية
 

تفضل
 
sours.xlsx result.xlsx

السلام عليكم و رحمة الله وبركاته
تم تنفيذ الكود المطلوب
Sub az() ' Dim FS As Worksheet, TS As Worksheet Dim FC, FR, TR, ER, Q1, Q2, Q3, SH Set FS = Sheets("أمور الشغل") ER = FS.UsedRange.Rows.Count For FR = 2 To ER Q1 = FS.Cells(FR, 4).Text ' المعدة Q2 = FS.Cells(FR, 1).Value ' رقم امر التشغيل For SH = 1 To ActiveWorkbook.Sheets.Count If Sheets(SH).Name = Q1 Then Set TS = Sheets(SH) ' ورقة السيارة Q3 = Application.CountIf(TS.Range("A:A"), Q2) If Q3 > 0 Then GoTo 3 TR = Application.CountA(TS.Range("A:A")) 4 If TS.Cells(TR, 1) <> "" Then TR = TR + 1 GoTo 4 End If For FC = 1 To 12 TS.Cells(TR, FC) = FS.Cells(FR, FC) Next FC End If Next SH 3 Next FR End Sub و لكن نصيحة
الاسهل
هو استخدام الجداول المحورية
او
استخدام التصفية التلقائية
او 
استخدام التصفية المتقدمة بالكود
و هذه الحلول افضل من استخدام الكود الموضح اعلاه
تحافظ على حجم الملف صغير 
و
كل تعديل في بيانات الورقة الاولى يظهر فورا
 
ولك حرية الاختيار
شيت امور الشغل.xls

و عليكم السلام و رحمة الله و بركاته
عند الكتابة في الخلية I3 ينتقل فورا الى H10
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$I$3" Then Range("H10").Select End Sub  
KHMP.xls

تعديل
للعمل على العامودين
 
 
جلب البيانات بشروط افقية وراسية.xls

السلام عليكم و رحمة الله وبركاته
 
اضغط زر فرز
Sub ماكرو1() ' If Range("M1") = "1" Then Range("B6:F280").SORT Key1:=Range("C6"), Order1:=xlAscending, Key2:=Range("D6") _ , Order2:=xlAscending, Key3:=Range("E6"), Order3:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _ xlSortNormal Range("M1") = "2" Else Range("B6:F280").SORT Key1:=Range("B6"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Range("M1") = "1" End If End Sub tist.rar

السلام عليكم
 
تفضل
 
نموزج فاتورة+بحث3.rar

السلام عليكم و رحمة الله وبركاته
 
1 تم تسمية النطاق للمبيعات ALL_SALS
2 يتم استخدام الدالة INDEX لتحديد العمود الذي به المعلومات بواسطة رقم العمود
3 يتم استخدام الدالة SUMPRODUCT لجمع القيم بعدة شروط
 
Book1.rar

السلام عليكم
 
تم المطلوب
و
استبدلنا TEXTBOX2 بــ COMPOBOX
وفعلنا به خاصية الإكمال التلقائي
وذلك لتسهيل عملية الإدخال
 
جرب
اصبح امامك قائمة منسدلة تختار منها الصنف
او
اكتب اول حرف من الصنف يظهر لك تلقائيا
 
 
Book2.rar

السلام عليكم و رحمة الله وبركاته
 
بعد اذن اخونا الكريم ابراهيم 
 
اخي ابو حنين
جرب الكود التالي
Sub Insert2ColmnValue() Columns("K:L").Copy With Range("K1") .Insert Shift:=xlToRight .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False .Select End With End Sub

السلام عليكم و رحمة الله وبركاته
 
اسعد الله صباحكم بكل خير
 
التنسيق
 
AZترقية.rar

السلام عليكم و رحمة الله
 
اخي محمد
 
بناء على طلبك السابق
 
في ورقة درجات الأولي وضعنا الشرط
اذا كان قيمة آخر تسلسل في ورقة اعدادات اكبر من قيمة آخر تسلسل في ورقة الأولي اذا نفذ الكود
وربطناه بالكود
 
في ورقة اعدادات اضفنا كود تشغيل الماكرو اذاكان تم تغيير اي خلية في العمود "B"
بمعنى اذفنا اي اسم
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then ãÇßÑæ1 End Sub والآن بمجرد اضافة اي اسم جديد
يتم اضافة الصفوف و الدول الجديدة في الورقة الأخرى
 
في حال تعديل اي اسم يتم تعديله تلقائيا بموجب الدوال دون اضافة اي صفوف جديدة
 
ارجو ان يكون كدة تمام
 
 
اضافة صف من صفحة اخرى.rar

جزاك الله خيرا
 
اخي الكريم
حدد الجدول
من القائمة بيانات - اختار- تصفية تظهر الأسهم
 
= = = =======================
 
ممكن كود VB يعمل على التصفية ويظهر المطلوب
 
ولكن انا فهمت انك ماتبغة اكواد فيجول وتبغة الحل بالدوال
 
 
 
 

السلام عليكم و رحمة الله وبركاته
 
اخي محمد خليل
الكلام الي قلته في آخر مشاركة اوحى الي بفكرة
بما انه لايوجد بيانات متكررة لإسم العميل و المنتج معا في الورقة الأصلية
اذا نحنة ممكن نسوي عملية تنظيف للورقة الأصلية فقط
نضيف اسم المنتج امام اسم كل عميل
نحذف بقية الصفوف كلها
نحذف الأعمدة الزائدة
' Application.Calculation = xlManual Set FS = Sheets(ActiveSheet.Name) ER = FS.UsedRange.Rows.Count Range("I1") = "ÇáäæÚ" Range("J1") = " ÇÓã ÇáÚãíá" Range("K2").EntireColumn.Insert Range("K2:K" & ER).FormulaR1C1 = "=IF(RC9="""",R[-1]C11,RC9)" FS.Calculate For R = 2 To ER If Cells(R, 10) <> "" Then Cells(R, 9) = Cells(R, 11) Next R ' Range("K2").EntireColumn.Delete Range("K2:K" & ER).FormulaR1C1 = "=AND(LEN(RC10)>1,LEN(RC9)>1,RC10<>R1C10)" FS.Calculate For R = 2 To ER If Cells(R, 11) <> "" And Cells(R, 11) = False Then Cells(R, 11).EntireRow.Delete R = R - 1 End If Next R Range("K2").EntireColumn.Delete Range("B1:H2").EntireColumn.Delete ' With ActiveSheet.UsedRange .Font.Size = 11 .Font.Name = "Arial" .ColumnWidth = 99 .Columns.AutoFit .Rows.AutoFit .AutoFilter End With ThisWorkbook.Save Application.Calculation = xlAutomatic كما في المرفق
 
Copy of Report3.rar

السلام عليكم
 
اخي
تم عمل اللازم على خلايا الصف 15 مع وجود القائمة
 
وطبقة انت على الباقي
 
ملاحظة
عند الدخول على التحقق من صحة يجب الغاء التأشير على خانة تجاهل الفراغ
 
Teat.rar

print all_AZ.rar

السلام عليكم و رحمة الله وبركاته
 
تحية طيبة
 
لا اعرف دالة تقوم بالمطلوب
ولكن ممكن كوود vb
 
خالص تحياتي وتقديري للجميع
وخاصة القائمين على المنتدى
 
داله اضافه القيمه بشكل اتوماتيك.rar