اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

قام بنشر (معدل)

السلام عليكم

ممكن جلب اسماء العملاء في ملف السجل خانة O تلقائيا على ضوء ما موجود في ملف الفواتير 

مع العلم بأن الفواتير كثير أكثر (11000) فاتورة

 

البيانات.rar

تم تعديل بواسطه ابوعبدالواجد
قام بنشر

وعليكم السلام أخي الكريم أبو عبد الواحد

في الملف المسمى "السجل" أدرج موديول جديد وضع الكود التالي فيه 

Sub ImportDataFromClosedWBs_YasserKhalil()
    Dim strFolder   As String
    Dim strFile     As String
    Dim wbk         As Workbook
    Dim sh          As Worksheet
    Dim lr          As Long

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .DisplayAlerts = False
        .AskToUpdateLinks = False
    End With
        strFolder = ThisWorkbook.Path & "\الفواتير\"
        strFile = Dir(strFolder & "*.xls*")
    
        Do While strFile <> ""
            Set wbk = Workbooks.Open(strFolder & strFile)
            Set sh = wbk.Worksheets(1)
            
            With ThisWorkbook.Worksheets(1)
                lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1)
                
                .Range("A" & lr).Resize(1, 6).Value = sh.Range("A7").Resize(1, 6).Value
                .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value
                .Range("I" & lr).Value = sh.Range("F1").Value
                .Range("J" & lr).Value = sh.Range("F2").Value
                .Range("K" & lr).Value = sh.Range("F3").Value
                .Range("O" & lr).Value = sh.Range("B2").Value
            End With
    
            wbk.Close False
            strFile = Dir
        Loop
    With Application
        .AskToUpdateLinks = True
        .DisplayAlerts = True
        .Calculation = xlAutomatic
        .ScreenUpdating = True
    End With
End Sub

 

  • Like 1
قام بنشر (معدل)

السلام عليكم - جزيت خيرا - جزيت خيرا - تقل الله منكم صالح الاعمال ونساله تعالى ان يرزقك من فضله 

اشكرك استاذ ياسر تمام 100 %

شغل محترفين - النتائج ممتازة

يرحم والديك 

 

تم تعديل بواسطه ابوعبدالواجد
  • Like 1
قام بنشر

وعليكم السلام

وجزيت خيراً بمثل ما دعوت لي أخي الكريم أبو عبد الواحد والحمد لله أن تم المطلوب على خير

ومشكور على دعائك الطيب ..

تقبل تحياتي وكل عام وأنت بخير

  • Like 1
قام بنشر

السلام عليكم : استاذ ياسر 

اود توضيح مسالة

قمت بادخال الفواتير وعند الضغط على زر تجميع الفواتير تبين بان المواد الموجودة في الفاتورة لم تأتي كلها ( فقط الصف الاول ) من الفاتورة

مما لم اتمكن من عمل تقرير بالمواد المباعة

رمضان مبارك - تقبل الله منكم صالح الاعمال - عيد سعيد

البيانات.rar

في ١٨‏/٦‏/٢٠١٧ at 14:39, ياسر خليل أبو البراء said:

وعليكم السلام أخي الكريم أبو عبد الواحد

في الملف المسمى "السجل" أدرج موديول جديد وضع الكود التالي فيه 


Sub ImportDataFromClosedWBs_YasserKhalil()
    Dim strFolder   As String
    Dim strFile     As String
    Dim wbk         As Workbook
    Dim sh          As Worksheet
    Dim lr          As Long

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .DisplayAlerts = False
        .AskToUpdateLinks = False
    End With
        strFolder = ThisWorkbook.Path & "\الفواتير\"
        strFile = Dir(strFolder & "*.xls*")
    
        Do While strFile <> ""
            Set wbk = Workbooks.Open(strFolder & strFile)
            Set sh = wbk.Worksheets(1)
            
            With ThisWorkbook.Worksheets(1)
                lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1)
                
                .Range("A" & lr).Resize(1, 6).Value = sh.Range("A7").Resize(1, 6).Value
                .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value
                .Range("I" & lr).Value = sh.Range("F1").Value
                .Range("J" & lr).Value = sh.Range("F2").Value
                .Range("K" & lr).Value = sh.Range("F3").Value
                .Range("O" & lr).Value = sh.Range("B2").Value
            End With
    
            wbk.Close False
            strFile = Dir
        Loop
    With Application
        .AskToUpdateLinks = True
        .DisplayAlerts = True
        .Calculation = xlAutomatic
        .ScreenUpdating = True
    End With
End Sub

 

 

البيانات.rar

  • 2 weeks later...
قام بنشر

وعليكم السلام

وكل عام وأنت بخير أخي الكريم

الملف المرفق يجب أن يكون معبر عن الملف الأصلي تماماً لكي يكون الكود مناسب للموضوع .. أمر آخر يرجى عدم اقتباس الأكواد في الردود لكي لا يطول الموضوع بدون داعي

جرب الكود التالي عله يفي بالغرض إن شاء الله

Option Explicit

Sub ImportDataFromClosedWBs_YasserKhalil()
    Dim strFolder       As String
    Dim strFile         As String
    Dim wbk             As Workbook
    Dim sh              As Worksheet
    Dim lr              As Long
    Dim i               As Long

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .DisplayAlerts = False
        .AskToUpdateLinks = False
    End With
        strFolder = ThisWorkbook.Path & "\الفواتير\"
        strFile = Dir(strFolder & "*.xls*")
    
        Do While strFile <> ""
            Set wbk = Workbooks.Open(strFolder & strFile)
            Set sh = wbk.Worksheets(1)
    
            With ThisWorkbook.Worksheets(1)
                i = 7
    
                Do
                    lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1)
                    .Range("A" & lr).Resize(1, 6).Value = sh.Range("A" & i).Resize(1, 6).Value
                    .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value
                    .Range("I" & lr).Value = sh.Range("F1").Value
                    .Range("J" & lr).Value = sh.Range("F2").Value
                    .Range("K" & lr).Value = sh.Range("F3").Value
                    .Range("O" & lr).Value = sh.Range("B2").Value
    
                    i = i + 1
                Loop Until sh.Range("A" & i).Value = ""
            End With
    
            wbk.Close False
            strFile = Dir
        Loop
    With Application
        .AskToUpdateLinks = True
        .DisplayAlerts = True
        .Calculation = xlAutomatic
        .ScreenUpdating = True
    End With
End Sub

 

  • Like 1
قام بنشر (معدل)

جزيت خير أستاذ ياسر  - وكل عام وانت بخير - ومشكور على الاهتمام بالموضوع

اعزك الله أستاذ ياسر - اود بيان الآتي :

الكود ممتاز وشيء مفرح افرحك الله في الدنيا والاخرة

فقط أستاذ مشكلة

وهي : الخلل في مجموع المشتريات والدفعات والمبالغ المتبقية ، إذ وردت مع كل مادة مجموع المشتريات ومجموع الدفعات ومجموع المبالغ المتبقية

مثلا الزبون صدام أبو امير كما مبين بالصورة ، مجموع المشتريات 2460000 - المفروض تذكر  مرة واحدة وكذلك الدفعات والمتبقي - حتى يكون التقرير بالمبالغ المباعه والمبالغ المستلمة والمبالغ المتبقية تمام كما قال في المشاركة الاولىCapture.JPG.cd1459f247dc6a2a91be8f73f4691699.JPG

 

تم تعديل بواسطه ابوعبدالواجد
قام بنشر

جرب نقل الأسطر التالية إلى قبل جملة End With

                    .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value
                    .Range("I" & lr).Value = sh.Range("F1").Value
                    .Range("J" & lr).Value = sh.Range("F2").Value
                    .Range("K" & lr).Value = sh.Range("F3").Value
                    .Range("O" & lr).Value = sh.Range("B2").Value

 

  • Like 1
  • أفضل إجابة
قام بنشر

لم تذكر شكل النتائج المتوقعة كما طلبت منك

عموماً جرب الكود بهذا الشكل

Option Explicit

Sub ImportDataFromClosedWBs_YasserKhalil()
    Dim strFolder   As String
    Dim strFile     As String
    Dim wbk         As Workbook
    Dim sh          As Worksheet
    Dim lr          As Long
    Dim i           As Long

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .DisplayAlerts = False
        .AskToUpdateLinks = False
    End With
        strFolder = ThisWorkbook.Path & "\الفواتير\"
        strFile = Dir(strFolder & "*.xls*")
    
        Do While strFile <> ""
            Set wbk = Workbooks.Open(strFolder & strFile)
            Set sh = wbk.Worksheets(1)
    
            With ThisWorkbook.Worksheets(1)
                i = 7
                lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1)
                
                .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value
                .Range("I" & lr).Value = sh.Range("F1").Value
                .Range("J" & lr).Value = sh.Range("F2").Value
                .Range("K" & lr).Value = sh.Range("F3").Value
                .Range("O" & lr).Value = sh.Range("B2").Value
    
                Do
                    .Range("A" & lr).Resize(1, 6).Value = sh.Range("A" & i).Resize(1, 6).Value
                    lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1)
                    i = i + 1
                Loop Until sh.Range("A" & i).Value = ""
            End With
    
            wbk.Close False
            strFile = Dir
        Loop
    With Application
        .AskToUpdateLinks = True
        .DisplayAlerts = True
        .Calculation = xlAutomatic
        .ScreenUpdating = True
    End With
End Sub

 

  • Like 1
قام بنشر

استاذي خليل. . . تدخل في موضوعي كمبوبوكس بطريقتين المنشور في منتدانا ولك مني جزيل الشكر. . 

قام بنشر
41 دقائق مضت, رشراش said:

استاذي خليل. . . تدخل في موضوعي كمبوبوكس بطريقتين المنشور في منتدانا ولك مني جزيل الشكر. . 

إذا كان لدي علم بالموضوع وفهمت المطلوب بشكل جيد لا أتردد في المشاركة أخي الكريم رشراش

ربما لو طرحت موضوع جديد وأرفقت ملف وذكرت كافة التفاصيل مع وضع بعض النتائج المتوقعة لربما وجدت المساعدة من الجميع وليس مني وحدي

كل عام وأنت بخير

  • Like 1
قام بنشر (معدل)
52 دقائق مضت, ياسر خليل أبو البراء said:

إذا كان لدي علم بالموضوع وفهمت المطلوب بشكل جيد لا أتردد في المشاركة أخي الكريم رشراش

ربما لو طرحت موضوع جديد وأرفقت ملف وذكرت كافة التفاصيل مع وضع بعض النتائج المتوقعة لربما وجدت المساعدة من الجميع وليس مني وحدي

كل عام وأنت بخير

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

https://www.officena.net/ib/topic/77975-كمبوبوكس-بطريقتين/

تم تعديل بواسطه رشراش

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information