اذهب الي المحتوي
أوفيسنا

جلب اسماء العملاء تلقائيا من ملف خارجي


إذهب إلى أفضل إجابة Solved by ياسر خليل أبو البراء,

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

السلام عليكم

ممكن جلب اسماء العملاء في ملف السجل خانة 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
رابط هذا التعليق
شارك

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

  • 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