هديتى مدونة_مينى كود_اسكتش_متجدد

[جلال الجمال_ابو أدهم]

هديتى
مدونة_مينى كود_اسكتش
من بحثى المتواضع بالانترنت 
رأيت عمل محفظة اكواد جاهزة مع التطبيق العملى للاستفادة
لذلك .... سيتم وضع اكواد بسيطة ( جاهزة و منفصلة )
للاستفادة منها عند انشاء الملفات و البرامج
و هى اكواد مرفوعة
و لطفا..... لعدم ذكر الاشخاص أو المواقع المرفوع منها الكود 
لأن الفكرة هنا هو عرض الكود و التطبيق العملى بصورة ميسرة
و لأنى ليس خبير بالاكواد(سيترك الشرح للاساتذة)
 سيرفق بالكود التطبيق العملى له بعد تعديله من رؤيتى المتواضعه للاكواد
و ارجو ان تروق لاعضاء المنتدى الفكرة
و نسألكم صالح الدعاء
تحياتى

[جلال الجمال_ابو أدهم]

1 _ كود ادخال ترحيل بيانات بطريقة رأسية

()Sub AddText
Dim Lrow As Single
With sheet1
   Lrow = .Range("B" & Rows.Count).End(xlUp).Row + 1
   .Range("B" & Lrow & ":K" & Lrow) = .Range("B3:K3").Value
   .Range("B3:K3").Value = ""
End With
End Sub

• ورقة تنفيذ الكود sheet1
• نطاق سطر الادخال للبيانات (B3:K3) يمكن تعديله بناء على البيانات المطلوب ادخالها
• بعد الضغط على زرار الترحيل سيتم ترحيل سطر الادخال بطريقة رأسية
• مرفق التطبيق العملى
  تحياتى و لا تنسونى من صالح الدعاء

كود ادخال و ترحيل بيانات_بطريقة رأسية_كود مينىadham.rar

[الجموعي]

بارك الله فيك أخي على هذا الموضوع

فعلا فكرة رائعة جدا

أسجل إعجابي وترحيبي بهذا الموضوع

بالتوفيق أخي

[حمادة عمر]

جزاك الله خيرا اخي الكريم

تقبل خالص تحياتي

[جلال الجمال_ابو أدهم]

 

 

 

 

جزاك الله خيرا اخي الكريم

تقبل خالص تحياتي

استاذى / حمادة عمر _ الجموعى _ حسام عيسى

تحياتى و شاكر مروركم الكريم

[ياسر خليل أبو البراء]

فكرة رائعة من أخ رائع

بارك الله فيك

بالفعل لو تم تنفيذ الفكرة لأصبح لدينا أشبه بمكتبة كبيرة يمكن الرجوع إليها دائما

يقوم الأخوة بوضع الأكواد ، وتتم مراجعتها من قبلك ومن قبل الأستاذ الكبير عبد الله باقشير لمراجعتها والتعديل عليها إن لزم الأمر ، بحيث يخرج العمل منقح ومصحح ويمكن الاستفادة منه بأقصى صورة ممكنة

[جلال الجمال_ابو أدهم]

 

فكرة رائعة من أخ رائع

بارك الله فيك

بالفعل لو تم تنفيذ الفكرة لأصبح لدينا أشبه بمكتبة كبيرة يمكن الرجوع إليها دائما

يقوم الأخوة بوضع الأكواد ، وتتم مراجعتها من قبلك ومن قبل الأستاذ الكبير عبد الله باقشير لمراجعتها والتعديل عليها إن لزم الأمر ، بحيث يخرج العمل منقح ومصحح ويمكن الاستفادة منه بأقصى صورة ممكنة

 

اخى ياسر خليل

شاكر مرورك و ارجو ان تنول الفكرة

رضاكم_تحياتى

[جلال الجمال_ابو أدهم]

2 _ كود ادخال ترحيل بيانات بطريقة رأسية مع اضافة كود ترتيب الصفوف تصاعدى

       و يصبح كود الادخال و الترحيل

Sub AddText()
Dim Lrow As Single
With sheet1
   Lrow = .Range("A" & Rows.Count).End(xlUp).Row + 1
   .Range("B" & Lrow & ":M" & Lrow) = .Range("B2:M2").Value
   .Range("B2:M2").Value = ""
    sortg_Click
End With
End Sub
 

مع اضافة كود ترتيب تصاعدى التالى:

Sub sortg_Click()
Range("B3:m1000").Sort Key1:=Range("b2"), Header:=xlNo
Range("b2").Select
End Sub 

ورقة تنفيذ الكود sheet1
نطاق سطر الادخال للبيانات (A2:M2) يمكن تعديله بناء على البيانات المطلوب ادخالها
بعد الضغط على زرار الترحيل سيتم ترحيل سطر الادخال بطريقة رأسية
يتم ازاحة و ترتيب الصفوف تصاعديا طبقا لمعلومية الرقم بالعمودC
مرفق التطبيق العملى
 

تحياتى و لا تنسونى من صالح الدعاء

 

كود ادخال و ترحيل بيانات_بطريقة رأسية_مع الترتيب_تصاعدى_كود مينىadham.rar

[محمود_الشريف]

أخى فى الله

الأستاذ الكريم// جلال الجمال

بارك الله فيكم وزادكم الله من فضله ومن علمه

تقبل منى وافر الاحترام والتقدير

[سلمان المجذوب]

جميل جدا ...يسلمؤؤؤؤ على هذا المجهود :fff:

[جلال الجمال_ابو أدهم]

 

أخى فى الله

الأستاذ الكريم// جلال الجمال

بارك الله فيكم وزادكم الله من فضله ومن علمه

تقبل منى وافر الاحترام والتقدير

 

استاذ / محمود الشريف 

بارك الله فيك

شاكر مرورك الكريم

[جلال الجمال_ابو أدهم]

جميل جدا ...يسلمؤؤؤؤ على هذا المجهود :fff:

استاذ / سلمان 

بارك الله فيك

شاكر مرورك الكريم

[إبراهيم ابوليله]

أخى جلال

اكواد جميله

وشرح اجمل

فى انتظار المزيد

بارك الله فيك

تقبل تحياتى

[الصـقر]

استاذى جلال الجمال 

بارك الله فيك وزداك من علمه وفى انتظار المزيد للتعلم منها

تقبل احترامى وتقديرى

[جلال الجمال_ابو أدهم]

أخى جلال

اكواد جميله

وشرح اجمل

فى انتظار المزيد

بارك الله فيك

تقبل تحياتى

استاذنا / ابراهيم ابو ليلة

شاكر كلماتك التى اعطتنى اكثر من عملى المتواضع

[جلال الجمال_ابو أدهم]

 

استاذى جلال الجمال 

بارك الله فيك وزداك من علمه وفى انتظار المزيد للتعلم منها

تقبل احترامى وتقديرى

 

استاذنا / حسام عيسى

شاكر مرورك و بارك الله فيك

[جلال الجمال_ابو أدهم]

3 _ كود ادخال ترحيل بيانات بطريقة رأسية مع  ترتيب الصفوف تصاعدى و بشرط عدم مسح خلية بها معادلة تكويد

Sub AddText()
With sheet1
    .Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 12).Value = .Range("B2").Resize(1, 12).Value
    .Range("B2,D2:M2").ClearContents
    With .Range("B3:M100")
        .Sort .Columns(2), xlAscending
    End With
End With
End Sub

ورقة تنفيذ الكود sheet1
نطاق سطر الادخال للبيانات (A2:M2) يمكن تعديله بناء على البيانات المطلوب ادخالها
بعد الضغط على زرار الترحيل سيتم ترحيل سطر الادخال بطريقة رأسية مع مسح البيانات و ابقاء صيغة المعادلة_التكويد بالخلية C2 
يتم ازاحة و ترتيب الصفوف تصاعديا طبقا لمعلومية الرقم بالعمودC
مرفق التطبيق العملى

تحياتى و لا تنسونى من صالح الدعاء

كود ادخال ترحيل بيانات بطريقة رأسية مع ترتيب الصفوف تصاعدى و بشرط عدم مسح خلية بها معادلة تكويد_مينى كود_adham.rar

[جلال الجمال_ابو أدهم]

4 _ كود ادخال ترحيل بيانات بطريقة رأسية _ برنامج التكويد و دليل الحسابات

مرفق التطبيق العملى

تحياتى و لا تنسونى من صالح الدعاء مرفق الملف مع الشرح

كود ادخال ترحيل بيانات بطريقة رأسية برنامج التكويد_مينى كود_adham.rar

[صلاح الصغير]

رائع ا \ جلال

استمر يا ريت الشرح يكون مفصل اكثر سطر سطر

للمبتدئين امثالى

[جلال الجمال_ابو أدهم]

 

رائع ا \ جلال

استمر يا ريت الشرح يكون مفصل اكثر سطر سطر

للمبتدئين امثالى

اخى / صلاح

شاكر مرورك

تحياتى

[جلال الجمال_ابو أدهم]

5_ كود ادخال ترحيل بيانات بطريقة رأسية مع يومية و ميزان مراجعه دبل كليك 2015_G_adham 

تم استخدام التكويد لدليل الحسابات السابق تنفيذه 

لتكويد حسابات ضمن برنامج محاسبى 
تحياتى للجميع

[جلال الجمال_ابو أدهم]

6 _ كود تلوين عمود و سطر الخلية النشطة المختارة
 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim rowNumberValue As Integer, columnNumberValue As Integer, i As Integer, j As Integer

Cells.Interior.ColorIndex = 0

rowNumberValue = ActiveCell.row
columnNumberValue = ActiveCell.column

For i = 1 To rowNumberValue
    Cells(i, columnNumberValue).Interior.ColorIndex = 37
Next i

For j = 1 To columnNumberValue
    Cells(rowNumberValue, j).Interior.ColorIndex = 40
Next j

End Sub

ورقة تنفيذ الكود sheet1
_ الكود يقوم بتظليل عمود و سطر الخلية المختارة
_يمكن تغيير لون التظليل بتغيير لون خلفية ورقة العمل من لون 0 الى لون اخر
_ يمكن تغيير لون التظليل بتغيير لون السطر من لون 37 الى لون اخر
_يمكن تغيير لون التظليل بتغيير لون العمود من لون 40 الى لون اخر 
مرفق التطبيق العملى

تحياتى و لا تنسونى من صالح الدعاء

كود تلوين عمود و سطر_الخلية المختارة_G_adham.rar

[مختار حسين محمود]

السلام عليكم

الفكرة ممتازة   يا أستاذ جلال  مرجع للجميع  على الهواء مباشرة

 

واسمح لى أن أقدم حته زيادة على موضوعك وهى محفظة للأكواد من أعمال الأستاذ عبدالله باقشير

يمكن أن نحفظ فيها الاكواد  للرجوع اليها اذا لم نكن على الهواء مباشرة

 

محفظة اكواد.rar

[احمد غانم]

الأخ الكريم جلال الجمال_ابو أدهم 

السلامعليكم

كود تلوين عمود و سطر الخلية النشطة المختارة في المشاركه رقم # 22

 

الكود رائع و مفيد جداَ خاصة في الجداول الكبيرة المزدحمة بالداتا و الأرقام

لكن مشكلته انة لا يمكن معه تلوين خلفيات الخلايا من لائحة التنسيق فعندما

يتم تلوين خلية بلون معين فإن الكود يقوم بمسحه؟ هل من حل ؟                 

[ياسر خليل أبو البراء]

أخي أحمد غانم

جرب الكود التالي لعله يفي بالغرض

Option Explicit
    
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim OffsetCol As Long, X As Long
Static ColorRange As Range, ColorIndexes() As Variant
    
Const COLUMNSDISPLAYED As Long = 60
    
    Application.ScreenUpdating = False
    If Not ColorRange Is Nothing Then
        For X = 1 To ColorRange.Columns.Count
            ColorRange.Cells(X).Interior.ColorIndex = ColorIndexes(X)
        Next
    Else
        On Error Resume Next
        Set ColorRange = Range(Sheet2.Cells(1).Value)
        On Error GoTo 0
        
        If Not ColorRange Is Nothing Then
            For X = 1 To ColorRange.Columns.Count
                ColorRange.Cells(X).Interior.ColorIndex = CLng(Split(Sheet2.Cells(2).Value, ",")(X - 1))
            Next
        End If
    End If
    
    OffsetCol = Application.Max(Target.Column - (COLUMNSDISPLAYED \ 2), 0)
    Set ColorRange = Range(Cells(Target.Row, 1 + OffsetCol), Cells(Target.Row, Application.Min(Columns.Count, Target.Column + (COLUMNSDISPLAYED \ 2))))
    ReDim ColorIndexes(1 To ColorRange.Columns.Count)
    
    For X = 1 To ColorRange.Columns.Count
        ColorIndexes(X) = ColorRange.Cells(X).Interior.ColorIndex
    Next
    Sheet2.Cells(1).Value = ColorRange.Address(0, 0, , -1)
    Sheet2.Cells(2).Value = CStr(Join(ColorIndexes, ","))
    
    ColorRange.Interior.ColorIndex = 36
    Application.ScreenUpdating = True
End Sub