Hussein888 قام بنشر السبت at 18:54 مشاركة قام بنشر السبت at 18:54 سلام عليكم ورحمة الله و بركاته.. سؤال بسيط لكن للاسف انا معلوماتي ف اكسيل تكاد تكون زيرو ف ارجو المساعدة.. عندي جدول ورديات لاربع جهات مختلفة كل يوم يكون في حارس لجهة من الجهات الاربعة لمدة يوم كامل.. الجدول شكله الاتي عمود (اليوم) ايام الشهر لاخره عمود (التاريخ) ايام الشهر بالتاريخ من 1 الى 30 عمود مخزن 1 عمود مخزن 2 عمود مخزن 3 عمود مخزن 4 تحت اعمدة المخازن الاربعة اسماء الاشخاص المنوط بهم القيام بالوردية لمدة 24 ساعة.. المطلوب بعد ما اكتب الجدول بالطريقة دي يتم تدوير البيانات بحيث يكون رؤوس الاعمدة هي الايام و التاريخ و الصفوف هي اسماء العاملين و القيم اسفل كل عمود من ايام الشهر هي رقم المخزن كالشكل الاتي.. (قمت بالتدوير يدويا) و شكرا جزيلا لكم رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر بالامس في 00:34 مشاركة قام بنشر بالامس في 00:34 (معدل) وعليكم السلام ورحمة الله تعالى وبركاته 1) يصعب التعامل مع الصور اخي الكريم المفروض إرفاق ملف للاشتغال عليه 2) الصورة المرفقة للنتائج المطلوبة تتضمن فقط مخزن 1 ومخزن 2 اين هو 3 و4 3) عدم تحديد مكان وضع النتائج على حسب ما فهمت من طلبك المفروض النتيجة المتوقعة تكون على الشكل التالي تم تعديل بالامس في 01:25 بواسطه محمد هشام. رابط هذا التعليق شارك More sharing options...
Hussein888 قام بنشر بالامس في 08:02 الكاتب مشاركة قام بنشر بالامس في 08:02 استاذ محمد هشام تحياتي لحضرتك اللي حضرتك ارسلته هو بالضبط المطلوب بعتذر عن عدم استكمال البيانات في الصورة الثانية لاني عملتها يدويا بايدي و كان في صعوبة ف استخلاص البيانات.. ف عملت مخزن 1 و مخزن 2 فقط و ماكملتش.. حضرتك عملت المطلوب تماما.. ياريت تديني شرح للطريقة و شكرا جزيلا 🌹 رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر منذ 17 ساعات مشاركة قام بنشر منذ 17 ساعات تم تنفيذها بواسطة كود vba يرجى إرفاق عينة لشكل البيانات لديك لتحديد النطاقات بشكل صحيح ومكان وضع النتائج المطلوبة تفاديا للأخطاء رابط هذا التعليق شارك More sharing options...
Hussein888 قام بنشر منذ 11 ساعات الكاتب مشاركة قام بنشر منذ 11 ساعات طيب لو في امكانية تكتبلي الكود وانا احاول اطبقه رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر منذ 8 ساعات مشاركة قام بنشر منذ 8 ساعات إدن لنفترض أننا سنقوم باستخراج البيانات من الأعمدة H:M كما هو ظاهر لديك على الصورة إلى ورقة 2 مثلا Sub CreateShift() Dim lastRow As Long, i As Long, j As Long, kay As String, c As String Dim tbl As Variant, Names As Collection, cell As Range, name As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = Sheets("Sheet2") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Application.WorksheetFunction.CountA(dest.Cells) > 0 Then dest.UsedRange.Clear lastRow = WS.Cells(WS.Rows.Count, 8).End(xlUp).Row tbl = WS.Range("H4:M" & lastRow).Value For i = 1 To lastRow - 3 dest.Cells(1, i + 1).Value = tbl(i, 2) dest.Cells(2, i + 1).Value = tbl(i, 1) If Application.CountA(Application.Index(tbl, i, 3)) > 0 Then Colors dest.Cells(1, i + 1), RGB(200, 200, 255) Colors dest.Cells(2, i + 1), RGB(255, 153, 0) End If Next i Set Names = New Collection On Error Resume Next For i = 1 To UBound(tbl, 1) For j = 3 To 6 If tbl(i, j) <> "" Then Names.Add tbl(i, j), CStr(tbl(i, j)) Next j Next i On Error GoTo 0 For i = 1 To Names.Count dest.Cells(i + 2, 1).Value = Names(i) Next i With dest.Range("A1:A2") .ClearFormats: .Merge: .Value = "الإســـم": .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter: .Font.Bold = True .Borders.LineStyle = xlContinuous: .Borders.color = RGB(0, 0, 255) .Interior.color = RGB(200, 200, 255) End With For i = 1 To lastRow - 3 For j = 1 To Names.Count If Not IsEmpty(dest.Cells(j + 2, 1)) Then name = Names(j) c = dest.Cells(1, i + 1).Value kay = "" For Each cell In WS.Range("J4:M" & WS.Cells(WS.Rows.Count, 10).End(xlUp).Row) If cell.Value = name And WS.Cells(cell.Row, 9).Value = c Then kay = (cell.Column - 9) & " مخزن" Exit For End If Next cell dest.Cells(j + 2, i + 1).Value = kay With dest.Range(dest.Cells(j + 2, 1), dest.Cells(j + 2, i + 1)) .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeBottom).color = RGB(0, 0, 255) End With End If Next j Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub Colors(cell As Range, color As Long) With cell .Interior.color = color .Font.Bold = True .Borders(xlEdgeBottom).LineStyle = xlContinuous End With End Sub New.xlsb رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان