كيف اعمل بيانات داتا لشركة في اكسل

**ا بو سليمان** · مارس 1, 2015

بالملف بيانات شركات

هذه اليانات تتحدث كل يوم مرة واحدة

كيف اعمل داتا لهذه اليانات لكل شركة لمدة شهرين او ثلاثة اشهر على ان تكون كل شركة على حدة في بياناتها وبعد الشهرين او الثلاثة اي اضافه يتم حذف اول بيانات مضى عليها شهرين او ثلاثة

بالنهاية يصبح لدي بيانات لكل شركة لمدة شهرين او ثلاثة واي زيادة يتم حذف بيانات اليوم الاول الذي وصل في ترتيبة رقم 60 او 90 حسب مدة البيانات

انني محتاج هذا العمل كثيرة فارجو المساعدة في ذلك مشكورين

بيانات شركة.rar

**أبوعيد** · مارس 2, 2015

تفضل

بيانات شركة1.rar

**الصـقر** · مارس 2, 2015

بعد أذن استاذى ابوعيد

استاذى الحبيب ابوسليمان

الملف المرفق ربما به طلبك

بعد تعبئة البيانات بشيت الرئيسية قم بالضغط على زر حفظ البيانات سوف يقوم الكود بترحيل البيانات الى شيت بيانات ( ملحوظه المفروض ان يقوم الكود بعد عملية الترحيل بمسح البيانات لادخال بيانات جديده ولكن انا معطل الخيار مؤقتا لحين ابداء رائيك )

وبعد عملية الحفظ يمكنك من شيت تقرير الاختيار من القائمة المنسدلة اسم الشركة والضغط على زر استدعاء التقرير سوف يقوم الكود بجلب جميع البيانات المرحله لهذه الشركة

لو عجبك فكرة الملف سوف اعمل ان تيسر لى الوقت ان يقوم الكود بمسح البيانات التى مر عليها اكثر من 90 يوم بشيت بيانات

تقبل تحياتى

بيانات شركة.zip

**شوقي ربيع** · مارس 2, 2015

السلام عليكم

الشكر موصول للاخ ابوعيد و الاخ الصقر

تفضل اخي هذا الحل ان شاء الله يفي بالغرض وان يستفيد منه الجميع

اولا تم برمجة كود يدرج شيت جديد باسم رمز الشركة اوتوماتيكيا في حالة زيادة عدد اسماء الشركات مع تنسيق رؤس الاعمدة كما هو في الشيت الرئيسي

Sub AddWs()
Dim ws As Worksheet
Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("ÇáÑÆíÓíÉ")
Dim lrw As Long: lrw = sh.Cells(Rows.Count, 1).End(xlUp).Row
Dim sNam As String
Dim i As Integer, c As Integer
Dim Err

For i = 2 To lrw
    sNam = sh.Range("A" & i).Value
    On Error GoTo Err
    Set ws = ThisWorkbook.Sheets(sNam)
0 Next

Exit Sub
Err:
    ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
    ThisWorkbook.Sheets(Sheets.Count).Name = sNam
    Set ws = ThisWorkbook.Sheets(sNam)
    Application.CutCopyMode = False
        sh.Range("C1:S1").Copy
        ws.Select
        ws.Range("A1").Select
        ws.Paste
    Application.CutCopyMode = True
    Feuil1.Activate
    GoTo 0
End Sub

ثانيا تم برمجة كود ينقل التغيرات الحاصلة في كل شركة الى الشيت الخاص بها اوتوماتيكيا ويومايا مع العلم ان البيانات تتحدث تلقائيا في حالت اي تغير في بيانات شركة ما ولا يتوقف التحديث الا في حالت تغير التاريخ

في هذه الحالة يتم ادراج البيانات في قاعدة البيانات الخاصة بتلك الشركة لاكن بتاريخ مختلف

ملاحظة تم برمجة الكود على اساس ان الشيت الرئيسة مرتبط باحد برامج البورصة (المضاربات) مثل مستشاري

Sub Rénover()
Dim ws As Worksheet
Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("ÇáÑÆíÓíÉ")
Dim lrw As Long: lrw = sh.Cells(Rows.Count, 1).End(xlUp).Row
Dim lrw2 As Long
Dim MyDat As Date
Dim sNam As String
Dim i As Integer, c As Integer
Call AddWs
For i = 2 To lrw
    
    MyDat = CDate(sh.Range("C" & i).Value)
    sNam = sh.Range("A" & i).Value
    Set ws = ThisWorkbook.Sheets(sNam)
    lrw2 = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Dim Rw As Long: Rw = lrw2 + 1
    If lrw2 = 1 Then
        ws.Range("A" & Rw & ":Q" & Rw).Value = sh.Range("C" & i & ":S" & i).Value
        GoTo 1
    ElseIf MyDat = CDate(ws.Range("A" & lrw2)) Then
        ws.Range("A" & lrw2 & ":Q" & lrw2).Value = sh.Range("C" & i & ":S" & i).Value
    Else
        ws.Range("A" & Rw & ":Q" & Rw).Value = sh.Range("C" & i & ":S" & i).Value
    End If

1 Next

End Sub

ثالثا تم برمجة كود يقوم بملئ كمبوبكس الخاص بالرمز و اسم الشركة ايضا يعمل اتوماتيكيا

Sub ListCmb()
    
    Set wsh = ThisWorkbook.Sheets("ÇáÑÆíÓíÉ")
        lLrw = wsh.Cells(Rows.Count, 1).End(xlUp).Row

        Feuil1.CobName.Clear
        Feuil1.CobID.Clear
        Feuil1.CobName.List = wsh.Range("B2:B" & lLrw).Value
        Feuil1.CobID.List = wsh.Range("A2:A" & lLrw).Value
    
End Sub

رابعا تم برمجة كود خاص بملئ التواريخ المسجلة في قاعدة البيانات ايضا يعمل اتوماتيكا حسب اسم او رمز الشركة المختارة

Sub ListCmbDate(wsNam As String)

    If wsNam = "" Then Exit Sub
    Set wsh = ThisWorkbook.Sheets(wsNam)
        lLrw = wsh.Cells(Rows.Count, 1).End(xlUp).Row
        Feuil1.CmbDat1.Clear
        Feuil1.CmbDat2.Clear
        If lLrw = 2 Then
            Feuil1.CmbDat1.AddItem wsh.Range("A2").Value
            Feuil1.CmbDat2.AddItem wsh.Range("A2").Value
        Exit Sub
        Else
            Valeurs = wsh.Range("A2:A" & lLrw).Value
            Feuil1.CmbDat1.List = Valeurs
            Feuil1.CmbDat2.List = Valeurs
        End If
End Sub

خامسا واخير تم برمجة كود يجلب البيانات حسب اختيار المستعمل للفترة التي يريد من شيت محدث

Sub RowWs(wsNam As String, MyDate1 As Date, MyDate2 As Date)
If wsNam = "" Then Exit Sub
CalearWs
    Set ws = ThisWorkbook.Sheets("ãÍÏË")
    Set wsh = ThisWorkbook.Sheets(wsNam)
        lLrw = wsh.Cells(Rows.Count, 1).End(xlUp).Row
Dim Rw As Long, Rw1 As Long, Rw2 As Long
For i = 2 To lLrw
If MyDate1 = CDate(wsh.Range("A" & i)) Then Rw1 = wsh.Range("A" & i).Row
If MyDate2 = CDate(wsh.Range("A" & i)) Then Rw2 = wsh.Range("A" & i).Row: Exit For
Next
If Rw1 = 0 Then MsgBox "íÌÈ Çä íßæä íæã ÇáÈÏÇíÉ ÇÞá ãä Çæ íÓÇæí íæã ÇáäåÇíÉ": Exit Sub
Rw = Rw2 - Rw1 + 1
ws.Range("A4").Resize(Rw, 15).Value = wsh.Range("A" & Rw1).Resize(Rw, 15).Value

End Sub

صورة توضيحية

ملاحضة هامة الرجاء عدم التغيير في تسميات الشيتات لكي لا يتأثر عمل الاكواد (الكود يعطي خطاء)

تحياتي للجميع

بيانات شركة.rar

**الصـقر** · مارس 2, 2015

بارك الله فيك اخى الحبيب شوقى ربيع

اكود اكثر من رائعه كنوز جديده يتم اضافتها للمكتبه عندى

زادك الله علما وتقبل تحياتى

**ا بو سليمان** · مارس 2, 2015

تفضل

بارك الله فيك اخي العزيز ابو عيد على جهك المميز

**ا بو سليمان** · مارس 2, 2015

بعد أذن استاذى ابوعيد

استاذى الحبيب ابوسليمان

الملف المرفق ربما به طلبك

بعد تعبئة البيانات بشيت الرئيسية قم بالضغط على زر حفظ البيانات سوف يقوم الكود بترحيل البيانات الى شيت بيانات ( ملحوظه المفروض ان يقوم الكود بعد عملية الترحيل بمسح البيانات لادخال بيانات جديده ولكن انا معطل الخيار مؤقتا لحين ابداء رائيك )

وبعد عملية الحفظ يمكنك من شيت تقرير الاختيار من القائمة المنسدلة اسم الشركة والضغط على زر استدعاء التقرير سوف يقوم الكود بجلب جميع البيانات المرحله لهذه الشركة

لو عجبك فكرة الملف سوف اعمل ان تيسر لى الوقت ان يقوم الكود بمسح البيانات التى مر عليها اكثر من 90 يوم بشيت بيانات

تقبل تحياتى

بارك الله فيك اخي العزيز الصقر وعلى جهودكم المميزة

**ا بو سليمان** · مارس 2, 2015

السلام عليكم

الشكر موصول للاخ ابوعيد و الاخ الصقر

تفضل اخي هذا الحل ان شاء الله يفي بالغرض وان يستفيد منه الجميع

اولا تم برمجة كود يدرج شيت جديد باسم رمز الشركة اوتوماتيكيا في حالة زيادة عدد اسماء الشركات مع تنسيق رؤس الاعمدة كما هو في الشيت الرئيسي
Sub AddWs()
Dim ws As Worksheet
Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("ÇáÑÆíÓíÉ")
Dim lrw As Long: lrw = sh.Cells(Rows.Count, 1).End(xlUp).Row
Dim sNam As String
Dim i As Integer, c As Integer
Dim Err

For i = 2 To lrw
    sNam = sh.Range("A" & i).Value
    On Error GoTo Err
    Set ws = ThisWorkbook.Sheets(sNam)
0 Next

Exit Sub
Err:
    ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
    ThisWorkbook.Sheets(Sheets.Count).Name = sNam
    Set ws = ThisWorkbook.Sheets(sNam)
    Application.CutCopyMode = False
        sh.Range("C1:S1").Copy
        ws.Select
        ws.Range("A1").Select
        ws.Paste
    Application.CutCopyMode = True
    Feuil1.Activate
    GoTo 0
End Sub
ثانيا تم برمجة كود ينقل التغيرات الحاصلة في كل شركة الى الشيت الخاص بها اوتوماتيكيا ويومايا مع العلم ان البيانات تتحدث تلقائيا في حالت اي تغير في بيانات شركة ما ولا يتوقف التحديث الا في حالت تغير التاريخ

في هذه الحالة يتم ادراج البيانات في قاعدة البيانات الخاصة بتلك الشركة لاكن بتاريخ مختلف

ملاحظة تم برمجة الكود على اساس ان الشيت الرئيسة مرتبط باحد برامج البورصة (المضاربات) مثل مستشاري
Sub Rénover()
Dim ws As Worksheet
Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("ÇáÑÆíÓíÉ")
Dim lrw As Long: lrw = sh.Cells(Rows.Count, 1).End(xlUp).Row
Dim lrw2 As Long
Dim MyDat As Date
Dim sNam As String
Dim i As Integer, c As Integer
Call AddWs
For i = 2 To lrw
    
    MyDat = CDate(sh.Range("C" & i).Value)
    sNam = sh.Range("A" & i).Value
    Set ws = ThisWorkbook.Sheets(sNam)
    lrw2 = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Dim Rw As Long: Rw = lrw2 + 1
    If lrw2 = 1 Then
        ws.Range("A" & Rw & ":Q" & Rw).Value = sh.Range("C" & i & ":S" & i).Value
        GoTo 1
    ElseIf MyDat = CDate(ws.Range("A" & lrw2)) Then
        ws.Range("A" & lrw2 & ":Q" & lrw2).Value = sh.Range("C" & i & ":S" & i).Value
    Else
        ws.Range("A" & Rw & ":Q" & Rw).Value = sh.Range("C" & i & ":S" & i).Value
    End If

1 Next

End Sub
ثالثا تم برمجة كود يقوم بملئ كمبوبكس الخاص بالرمز و اسم الشركة ايضا يعمل اتوماتيكيا
Sub ListCmb()
    
    Set wsh = ThisWorkbook.Sheets("ÇáÑÆíÓíÉ")
        lLrw = wsh.Cells(Rows.Count, 1).End(xlUp).Row

        Feuil1.CobName.Clear
        Feuil1.CobID.Clear
        Feuil1.CobName.List = wsh.Range("B2:B" & lLrw).Value
        Feuil1.CobID.List = wsh.Range("A2:A" & lLrw).Value
    
End Sub
رابعا تم برمجة كود خاص بملئ التواريخ المسجلة في قاعدة البيانات ايضا يعمل اتوماتيكا حسب اسم او رمز الشركة المختارة
Sub ListCmbDate(wsNam As String)

    If wsNam = "" Then Exit Sub
    Set wsh = ThisWorkbook.Sheets(wsNam)
        lLrw = wsh.Cells(Rows.Count, 1).End(xlUp).Row
        Feuil1.CmbDat1.Clear
        Feuil1.CmbDat2.Clear
        If lLrw = 2 Then
            Feuil1.CmbDat1.AddItem wsh.Range("A2").Value
            Feuil1.CmbDat2.AddItem wsh.Range("A2").Value
        Exit Sub
        Else
            Valeurs = wsh.Range("A2:A" & lLrw).Value
            Feuil1.CmbDat1.List = Valeurs
            Feuil1.CmbDat2.List = Valeurs
        End If
End Sub
خامسا واخير تم برمجة كود يجلب البيانات حسب اختيار المستعمل للفترة التي يريد من شيت محدث
Sub RowWs(wsNam As String, MyDate1 As Date, MyDate2 As Date)
If wsNam = "" Then Exit Sub
CalearWs
    Set ws = ThisWorkbook.Sheets("ãÍÏË")
    Set wsh = ThisWorkbook.Sheets(wsNam)
        lLrw = wsh.Cells(Rows.Count, 1).End(xlUp).Row
Dim Rw As Long, Rw1 As Long, Rw2 As Long
For i = 2 To lLrw
If MyDate1 = CDate(wsh.Range("A" & i)) Then Rw1 = wsh.Range("A" & i).Row
If MyDate2 = CDate(wsh.Range("A" & i)) Then Rw2 = wsh.Range("A" & i).Row: Exit For
Next
If Rw1 = 0 Then MsgBox "íÌÈ Çä íßæä íæã ÇáÈÏÇíÉ ÇÞá ãä Çæ íÓÇæí íæã ÇáäåÇíÉ": Exit Sub
Rw = Rw2 - Rw1 + 1
ws.Range("A4").Resize(Rw, 15).Value = wsh.Range("A" & Rw1).Resize(Rw, 15).Value

End Sub
صورة توضيحية

ملاحضة هامة الرجاء عدم التغيير في تسميات الشيتات لكي لا يتأثر عمل الاكواد (الكود يعطي خطاء)

تحياتي للجميع

رررررررررررررائع ومميز اخي العزيز شوقي ربيع

محمد لطفى · مارس 6, 2015

رائع

تسجيل الدخول

كيف اعمل بيانات داتا لشركة في اكسل

الردود الموصى بها

ا بو سليمان

رابط هذا التعليق

شارك

أبوعيد

رابط هذا التعليق

شارك

الصـقر

رابط هذا التعليق

شارك

شوقي ربيع

رابط هذا التعليق

شارك

الصـقر

رابط هذا التعليق

شارك

ا بو سليمان

رابط هذا التعليق

شارك

ا بو سليمان

رابط هذا التعليق

شارك

ا بو سليمان

رابط هذا التعليق

شارك

محمد لطفى

رابط هذا التعليق

شارك

من فضلك سجل دخول لتتمكن من التعليق

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information