ابو تراب

فكرة جميل فعلا...جزاك الله خيرا

الملف الذي ارفقت يعمل تغييرات في قيم سجل النظام.

السلام عليكم ليس لدي قارئ باركود و لكن استخدم جوالي كقارئ للباركود و لا احتاج لبرمجة الاكسل... (قارئ الباركود لديك يفترض ان يعمل بدون برمجة) كل ما اعمله هو اختيار الخلية المراد تخزين الكود فيها و بعدها اعمل سكان للكود فقط. ما يحدث هو ند عمل سكان للخلية و لتكن مثلا A1 يتم ادخال الكود فيها و بعدها يتم تماتيكيا اختيار الخلية التى تليها و هي A2 ملاحظة -------- نسق خلية الباركود بحث تكن تنسيق Number وذلك لسهولة قرائة الارقام جرب المثال المرفق barcode.zip

فضلا شيك على صندوق الرسائل بالتوفيق

وعليكم السلام كحل سريع استخدم الدالة SUM مثلا بدل: K10-J10-I10-G10 بــ Sum(K10)-Sum(J10)-Sum(I10)-Sum(G10)

جرب الكود بالتوفيق المصنف - تجربة.zip

هلا سامي يمكنك عمل مرجع لشيت معين مع خليتها عن طريق الدالة Indirect جرب المعادلة التالية: INDIRECT("'"&$A2&"'!$H$1")

هلا ايهاب الغرض من الكود هو اعطائك حرية تحديد اكثر من جدول لتعبئة البيانات على شرط ان كل جدول عدد صفوفه 30 صف. والفكرة في تحقيق ذلك: 1- انشاء مصفوفة تضع فيها مدى الجداول...في الملف المرفق و ضعت مدى الجدولين: Dim Tables() As String Tables = Split("A11:F40,G11:L40", ",") مدى الجدول الاول هو A11:F40 و الجدول الثاني هو G11:L40 (بالطبع يمكنك و ضع جدول ثالث و رابع على حسب الرغبة) 2- انشاء دالة ذات مرجع لنفسها او الدالة التي تستدعي نفسها Recursive function. مهمة هذه الدالة تعبئة الجدول. فاذا كان الجدول الاول ممتلئ و لا يوجد تطابق تستدعي الدالة نفسها لتبحث في الجدول الثاني و هكذا الى ان تحدث الجدول. في حالة جميع الجداول ممتلئة و لايوجد تطابق في اي سطر ترجع القيمة False دلالة على امتلاء جميع الجداول. Public Function UpdateTable(ByRef Tables() As String, TableIndex As Integer, SKey As String, SIndex As Integer) As Boolean Tables : يمثل مصفوفة الجداول TableIndex : يمثل رقم الجدول. الرقم 0 يعني الجدول الاول و الرقم 1 يمثل الجدول الثاني و هكذا. SKey: مفتاح المركب في جدول المصدر SIndex : يمثل رقم السطر في جدول المصدر Sub btnTransfer() Dim Tables() As String Tables = Split("A11:F40,G11:L40", ",") Dim SKey As String Dim Found As Boolean Dim i As Integer For i = 2 To 6 If Val(Range("B" & i)) <> 0 Then SKey = Range("A" & i) & Range("E" & i) Found = UpdateTable(Tables, 0, SKey, i) If Not Found Then MsgBox "الجداول ممتلئة..لم يتم ترحيل من السطر رقم: " & i, vbCritical + vbOKOnly, "خطأ في الترحيل" Exit For End If End If Next i End Sub Public Function UpdateTable(ByRef Tables() As String, TableIndex As Integer, SKey As String, SIndex As Integer) As Boolean Dim Table As Range Dim DKey As String Dim LR As Integer Dim j As Integer Dim Found As Boolean Set Table = Range(Tables(TableIndex)) LR = Table.Cells(31, 1).End(xlUp).Row If LR < 11 Then LR = 0 Else LR = LR - 10 End If Found = False For j = 1 To LR DKey = Table.Cells(j, 1) & Table.Cells(j, 2) If SKey = DKey Then Select Case Range("F" & SIndex) Case Table.Cells(0, 4) Table.Cells(j, 4) = Val(Table.Cells(j, 4)) + Val(Range("B" & SIndex)) Case Table.Cells(0, 5) Table.Cells(j, 5) = Val(Table.Cells(j, 5)) + Val(Range("B" & SIndex)) Case Table.Cells(0, 6) Table.Cells(j, 6) = Val(Table.Cells(j, 6)) + Val(Range("B" & SIndex)) End Select Found = True Exit For End If Next j If Not Found And LR < 30 Then Table.Cells(LR + 1, 1) = Range("A" & SIndex) Table.Cells(LR + 1, 2) = Range("E" & SIndex) Select Case Range("F" & SIndex) Case Table.Cells(0, 4) Table.Cells(LR + 1, 4) = Val(Range("B" & SIndex)) Case Table.Cells(0, 5) Table.Cells(LR + 1, 5) = Val(Range("B" & SIndex)) Case Table.Cells(0, 6) Table.Cells(LR + 1, 6) = Val(Range("B" & SIndex)) End Select Found = True في حالة امتلأ الجدول الحالي و لا يوجد تطابق في اي سطر و عدد الجداول التي تم البحث فيها اقل من العدد الكلي ElseIf Not Found And TableIndex < UBound(Tables) Then الدلة تستدعي نفسها لتبحث في الجدول التالي Found = UpdateTable(Tables, TableIndex + 1, SKey, SIndex) End If UpdateTable = Found End Function

وعليكم السلام و رحمة الله جرب الكود المرفق توقيع.zip

هلا ابو حنين جرب الكود التالي ملاحظة: كلمة سر حماية الورقة هى 123 بيانات التاريخ و المبلغ ستغلق و تكن للقرأة فقط عند ادخال التوقيق لم اضع كلمة سر لكود VBA .. يمكنك اذا اردت وضعها توقيع.zip

وعليكم السلام فضلا جرب المف توقيع.zip

هلا احمد عدلت لك الكود... المشكلة بسيطة وهى انك تستخدم خلية مدمجة merged بدلا عن خلية عادية Book1.zip

اختر جميع خلاياء الشيت عن طريق Ctrl + A اضغط Ctrl + 1 اختر Protection الغي الخيار Locked , و الخيار Hidden و اختر OK بعدها اختر الخلية التي فيها المعادلة و اضغط Ctrl + 1 اختر Protection فعل الخيار Locked , و الخيار Hidden و اختر OK بعدها من الائمة Preview اختر Protect Sheet و اخل كلمة سر جديدة

وعليكم السلام الغي الخيار كما هو موضح في الصورة:

هلا ابو نبأ جرب المرفق ملاحظة ===== عدلت لك الكود بحيث يمكنك من استخدامها في شيت البيانات و شيت البطاقة كيفية استدعاد الدالة =InsertPic("البطاقة","D:\صور\"&$B$1&".jpg",$B$1,1,3) CurSheet: يمثل اسم الشيت الحالية...مثال: البطاقة PicPath : يمثل مسار الصورة مثلا : "D:\صور\"&$B$1&".jpg" حيث الخلية B1 هيى رقم الموظف PicName : اسم الصورة مثال B1 حيث ثمثل رقم الموظف Row : رقم سطر الخلية المراد وضع الصورة فيها... هنا نضع 1 لان الخلية في المثال المرفق هى C1 Col : يمثل رقم عمود خلية الصورة... C1 و هنا سنضع الرقم 3 لان الحرف C يمثل الرقم ثلاثة Public Function InsertPic(CurSheet As String, PicPath As String, PicName As String, Row As Long, Col As Long) Dim pic As Shape Dim PicWidth As Double Dim PicHeight As Double Dim WBSheet As Worksheet Set WBSheet = Sheets(CurSheet) For Each pic In WBSheet.Shapes If pic.Name = PicName Then pic.Delete Next With WBSheet.Pictures.Insert(PicPath) With .ShapeRange .LockAspectRatio = msoFalse .Width = WBSheet.Cells(Row, Col).Width .Height = WBSheet.Cells(Row, Col).Height .Name = PicName End With .Left = WBSheet.Cells(Row, Col).Left .Top = WBSheet.Cells(Row, Col).Top .Placement = 1 .PrintObject = True End With Set WBSheet = Nothing End Function بطاقة الموظف.zip

هلا ماجد جرب الكود المرفق 99999999.zip

تفضل احمد جرب المرفق Book1.zip

اخي ايهاب جرب المرفق ترحيل من جدول لجدول.zip

الفكرة انه لديك جدولين و تم الربط بينهما عن طريق مفتاح مركب (التاريخ و البيان) -- نفس فكرة جداول الأكسس composite primary key. وقد تم تعريف متغيرين الاول Skey يمثل مفتاح الجدول الاول و Dkey يمثل مفتاح الجدول الثاني. اذا تطابق المفتحان يتم اختيار الشريك المناسب و تحديت البيانات. في حالة لا يوجد تطابق للمفتاحين في اي سطر من اسطر الجدول الثاني يتم اضافة سطر جديد و تحديث البيانات. Sub btnTransfer() Dim i As Integer Dim j As Integer Dim LR As Integer Dim SKey As String Dim DKey As String Dim Found As Boolean اقرأ اسطر الجدول الاول For i = 2 To 6 تأكد من وجود قيمة في خلية المسحوبات If Val(Range("B" & i)) <> 0 Then حدث بيانات مفتاح الجدول الاول SKey = Range("A" & i) & Range("E" & i) حدث قيمة السطر الاخير في الجدول الثاني LR = [A10000].End(xlUp).Row اذا كان الجدول الثاني فارغا فأبد من الخلية رقم A11 If LR < 11 Then LR = 10 Found = False اقرأ اسطر الجدول الثاني For j = 11 To LR DKey = Range("A" & j) & Range("B" & j) في حالة تطابق المفتاحان حدث البيانات If SKey = DKey Then Select Case Range("F" & i) Case [D10] Range("D" & j) = Val(Range("D" & j)) + Val(Range("B" & i)) Case [E10] Range("E" & j) = Val(Range("E" & j)) + Val(Range("B" & i)) Case [F10] Range("F" & j) = Val(Range("F" & j)) + Val(Range("B" & i)) End Select Found = True Exit For End If Next j في حالة عدم التطابق اضف سطر جديد If Not Found Then Range("A" & LR + 1) = Range("A" & i) Range("B" & LR + 1) = Range("E" & i) Select Case Range("F" & i) Case [D10] Range("D" & LR + 1) = Val(Range("B" & i)) Case [E10] Range("E" & LR + 1) = Val(Range("B" & i)) Case [F10] Range("F" & LR + 1) = Val(Range("B" & i)) End Select End If End If Next iEnd Sub

هلا ايهاب جرب المرفق ترحيل من جدول لجدول.zip

الشكر لله اخي احمد تفضل جرب المرفق معادلة الايام بعد التعديل: TRUNC((((($W8/360)-$P8)*12)-$O8)*30) حساب مدد.zip

هلا احمد ستجد طلبك في الموضوع التالي: http://www.officena.net/ib/index.php?showtopic=57178&hl=

ممكن ترسل جزء من البيانات التى اضهرت الخطا خصوصا السطر رقم 25

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

وعليكم السلام عدلت لك الملف بحيث يمكنك تتحكم بابعاد الصورة دون التقيد بالابعاد الحقيقية للصورة. جرب الملف و خبرنا رفع الصور في الاكسل.zip