حسين مامون

جرب
Copy of Copy of نموذج بيانات.xlsm

Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("n2:p1000000")) Is Nothing Then 'ÇÐÇ Êã ÊÍÏíÏ Çí ÎáíÉ Ýí ÇáãÏì ÇáãÐßæÑ äÝÏ ÇáÓØÑ ÇáÊÇáí Target.Offset(, 1).Select 'ÇÒÇÍÉ ãÞÏÇÑ 1 ãä ÇáÎáíÉ ÇáãÍÏÏÉ End If End Sub يمكنك اضافة اعمدة اخرى باستعمال Elseifمبيعات كانليمون جاردن 8.xlsm

تفضل
تعديل فاتورة (1).xlsm

اضف هذا السطر للكود في الزر المسمى "تعديل"
If TextBox6 = "" Then MsgBox "المرجو ادخال الرمز في المربع الاصفر ": Exit Sub الصورة 

بما انك لم ترفع ملف نمودج عما تريد اليك هاذا الشيء ربما تستفيذ منه
listC.xlsm

الكود الاول في حدث Workbook_Open
وهو يفعل كود test2 ثم يخفي الاكسيل ويظهر الفورم
Private Sub Workbook_Open() test2 Application.Visible = False UserForm1.Show End Sub وهذه صورة الكود داخل محرر الاكواد

وهذه الاكواد داخل الفورم
Private Sub CommandButton1_Click() ThisWorkbook.Save Application.Quit End Sub Private Sub CommandButton2_Click() Unload Me Application.Visible = True Sheets(1).Activate End Sub  صورة الفورم

 
وهذا الكود في مديول 
Sub test2() Dim lr Dim x, m lr = Cells(Rows.Count, "d").End(3).Row For x = 3 To lr Dim DT1, DT2 If CDate(Cells(x, "e")) = Date Then Cells(x, "f").Value = "هذا الشيك حان موعده" Cells(x, "f").Interior.Color = 255 Else Cells(x, "f").Interior.Color = xlNone Cells(x, "f").Value = "" End If Next x وهذه صور للصفحة

استعمل هذا الكود واكتفي  بزر واحد فقط 
Sub RN() If Not Intersect(Columns(3), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell.Offset(, 1) = Val(ActiveCell + 1) '======= ElseIf Not Intersect(Columns(5), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell = "x" & ActiveCell ActiveCell.Offset(, 8) = "x" '======= ElseIf Not Intersect(Columns(8), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell.Offset(, 1) = ActiveCell ActiveCell = "x" & ActiveCell '======= ElseIf Not Intersect(Columns(10), ActiveCell) Is Nothing Then If ActiveCell = "" Then Exit Sub ActiveCell.Offset(, 4) = "x" ActiveCell = "x" & ActiveCell End If End Sub  
الترحيل بالماكرو (1).xlsb

جرب هذا الشيء
Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim WS2 As Worksheet Set WS2 = Sheets("Price list Gouna") Dim RG, lr Dim x, RT Set RG = WS2.ListObjects("Table2").Range Set RT = ActiveSheet.Range("k3:k120000") lr = RG.Find(WHAT:="*", AFTER:=RG.Cells(1), lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _ searchdirection:=xlPrevious, MatchCase:=False).Row '================== If Not Intersect(Target, RT) Is Nothing Then For x = 3 To lr If WS2.Cells(x, 1).Text = Target Then Target.Offset(, -1).Value = WS2.Cells(x, 3).Value Target.Offset(, -3).Value = WS2.Cells(x, 2).Value Exit For End If Next x End If End Sub 1096400303_test(5).xlsm

ThisWorkbook.Sheets("sheet3").ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "oo", OpenAfterPublish:=True  

Private Sub Worksheet_Change(ByVal Target As Range) ' ' On Error Resume Next If Not Intersect(Target, Range("a2:a10000")) Is Nothing Then Target.Offset(, 1) = Format(Date, "dd-mm-yyyy") End If End Sub ضع الكود في حدث الشيت 
ادخال البيانات في العمود 1 ويظهر التاريخ في العمود2

جرب المرفق
معلومات فنية اتصالات.xlsm

ربما يفيدك هذا الفيديو للاستاذ المحترم عماد غازي
 
 

ربما هذا الكود ينفذ ما تقصد
كهرباء المخيم.xlsm

كان عليك رفع ملف فيه شرح كافي 
ولكن ربما تستفيد من هذا الملف
TEST22.xlsm

تفضل
اختر من الكومبوبوكس اي اسم
ثم اختر من الليست 
عدل ما تشاء 
واضغط زر تعديل
بحث بمعيار الأسم ثم معيار التاريخ-1.xlsb

فك الضغط وخزن المجلد في اي فولدر 
documen.rar

Sub tous_COD() Generate_Test Q_Rand End Sub  
 

جرب هذا العمل 
الكود يبحث في جميع الصفحات الا صفحة التقرير
2020 الحسابات (1).xlsm

بعد ادنكم
ربما تقصد هذا الشيء
Classeur1.xlsx

استعن بهذا الفيديو .... وهذا هو ملفك وعليك أيضاً أولا تحميل نوع الخط المرفوع مع ملفك
 
ccode39.zip باركود 2022.xlsx

بعد ادن الاساتدة ربما هذا الشيء يفي بالغرض
PRT.xlsm

Option Explicit Sub test() Dim lr, c, x, r, lr2 Dim ws As Worksheet Set ws = Sheets("DATA") Dim ws2 As Worksheet Set ws2 = Sheets("الطباعة") c = ws.[d3] r = 6 Application.ScreenUpdating = False With ws ws2.Range("a6:d1000").ClearContents ws2.Range("a6:d1000").Borders.LineStyle = 0 lr = .Cells(Rows.Count, 1).End(3).Row For x = 6 To lr Select Case .Cells(x, 1).Value2: Case c ws2.Range("b4").Value = .Cells(x, 1).Value ws2.Range("a" & r).Value = .Cells(x, "e").Value ws2.Range("a" & r).Offset(, 1).Value = .Cells(x, "d").Value ws2.Range("a" & r).Offset(, 2).Value = .Cells(x, "b").Value ws2.Range("a" & r).Offset(, 3).Value = .Cells(x, "c").Value ws2.Range("a" & r).Resize(, 4).Borders.LineStyle = xlDot r = r + 1 End Select Next x lr2 = ws2.Cells(Rows.Count, 1).End(3).Row + 2 ws2.Range("b" & lr2) = "اجمالي" ws2.Range("c" & lr2) = WorksheetFunction.Sum(ws2.Range("c6:c" & r - 1)) ws2.Range("d" & lr2) = WorksheetFunction.Sum(ws2.Range("d6:d" & r - 1)) If ws2.Range("c" & lr2) > ws2.Range("d" & lr2) Then ws2.Range("b" & lr2).Offset(1) = "اجمالي مدين" ws2.Range("c" & lr2).Offset(1) = ws2.Range("c" & lr2) - ws2.Range("d" & lr2) ElseIf ws2.Range("c" & lr2) < ws2.Range("d" & lr2) Then ws2.Range("b" & lr2).Offset(1) = "اجمالي دائن" ws2.Range("c" & lr2).Offset(1) = ws2.Range("d" & lr2) - ws2.Range("c" & lr2) End If '==================== ws2.Range("a" & lr2).Resize(1, 4).Interior.Color = 49407 ws2.Range("a" & lr2 + 1).Resize(1, 4).Interior.ThemeColor = xlThemeColorAccent5 With ws2.Range("a" & lr2).Resize(2, 4).Borders(xlEdgeTop) .LineStyle = xlDot .Weight = xlThin End With With ws2.Range("a" & lr2).Resize(2, 4).Borders(xlEdgeBottom) .LineStyle = xlDot .Weight = xlThin End With With ws2.Range("a" & lr2).Resize(2, 4).Borders(xlEdgeRight) .LineStyle = xlDot .Weight = xlThin End With With ws2.Range("a" & lr2).Resize(2, 4).Borders(xlEdgeLeft) .LineStyle = xlDot .Weight = xlThin End With With ws2.Range("a" & lr2).Resize(2, 4).Borders(xlEdgeTop) .LineStyle = xlDot .Weight = xlThin End With '====================== ws2.Activate End With Application.ScreenUpdating = True End Sub  

جرب هذا الشيء
استعلام حسب ايام الشهر.xlsm

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

جرب هذا الشيء
sub PRINT_OUT Range("a1:f32").Printout end sub