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

[ابوعبدالواجد]

السلام عليكم

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

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

 

البيانات.rar

تم تعديل يونيو 18, 2017 بواسطه ابوعبدالواجد

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

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

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

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

 

[ابوعبدالواجد]

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

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

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

يرحم والديك 

 

تم تعديل يونيو 18, 2017 بواسطه ابوعبدالواجد

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

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

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

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

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

[ابوعبدالواجد]

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

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

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

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

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

البيانات.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

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

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

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

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

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

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

 

[ابوعبدالواجد]

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

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

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

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

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

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

 

تم تعديل يونيو 29, 2017 بواسطه ابوعبدالواجد

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

جرب نقل الأسطر التالية إلى قبل جملة 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

 

[ابوعبدالواجد]

السلام عليكم - جزيت خيرا

النتيجة كالآتي - تأتي البيانات في الصورة رقم 2 

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

ليس هذا الموضع الذي قصدته .. انظر بالأعلى قليلاً ستجد جملة End With  أخرى قبلها ...

[ابوعبدالواجد]

هذه المرة لم تظهر أي نتائج

 

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

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

[ابوعبدالواجد]

مشكور أستاذ - جزيت خيرا

 

البيانات.rar

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

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

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

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

 

[ابوعبدالواجد]

الله يرحم والديك

الكود جلب البيانات بدقة 100 % - هذا هو المطلوب

جزيت خيرا

 

 

 

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

وجزيت خيراً بمثل ما دعوت لي أخي العزيز 

والحمد لله أن تم المطلوب على خير

[رشراش]

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

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

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

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

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

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

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

[رشراش]

52 دقائق مضت, ياسر خليل أبو البراء said:

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

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

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

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

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

تم تعديل يونيو 30, 2017 بواسطه رشراش