أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
ashraf_hertlion hassona229-- لا تميز خلال هذه الفترة YasserKhalil مطلوب تعديل الكود للطباعة اكسيل اسئله واجابات


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





تعديل كود استدعاء من ملف مغلق الحلقة التكرارية تجعله ياخد وقت طويل جدااا

السلام عليكم ممكن تعديل كود استدعاء من ملف مغلق الحلقة التكرارية تجعله ياخد وقت طويل جدااا اذا كان عدد الصفوف 10000 او ا ..


موضوع مغلق


23-01-2021 12:09 صباحا
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 

السلام عليكم ممكن
تعديل كود استدعاء من ملف مغلق الحلقة التكرارية تجعله ياخد وقت طويل جدااا اذا كان عدد الصفوف 10000 او اكثر
ربنا يرضى عنكم
Option Explicit

Sub GetDataDemo()

      Dim FilePath$, Row&, Column&, Address$
      Dim mpth
      Dim mfL
      'change constants & FilePath below to suit
      '***************************************
      Const FileName$ = "**"
      Const SheetName$ = "ورقة1"
      Const NumRows& = 10
      Const NumColumns& = 10
      Dir (mpth & "*xls*")
      mpth = ThisWorkbook.Path & "\do\"
      mfL = Dir(mpth & "*xls*")
      '***************************************
      
      DoEvents
      Application.ScreenUpdating = False
      If Dir(mpth & mfL) = Empty Then
            MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
            Exit Sub
      End If
      For Row = 1 To NumRows
            For Column = 1 To NumColumns
                  Address = Cells(Row, Column).Address
                  Cells(Row, Column) = GetData(mpth, mfL, SheetName, Address)
                  Columns.AutoFit
            Next Column
      Next Row
      ActiveWindow.DisplayZeros = False
End Sub

Private Function GetData(Path, File, Sheet, Address)
      Dim Data$
      Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _
            Range(Address).Range("A1").Address(, , xlR1C1)
      GetData = ExecuteExcel4Macro(Data)
End Function
 
 
  من الى.rar   تحميل rar مرات التحميل :(11)
الحجم :(26.656) KB



أفضل إجابة مقدمة من ابراهيم الحداد وهي:
السلام عليكم ورحمة الله
ربما يفيدك هذا الكود 
هذا و الله اعلى و اعلم
Sub CopyRange()
t = timr
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.DisplayClipboardWindow = False
    Dim desWS As Worksheet, srcWB As Workbook, s As String
    Set desWS = ThisWorkbook.Sheets("ورقة1")
    Dim LastRow As Long
'   Const strPath As String = "E:\ClosedFiles\افضل حل\do\"
    Dim strPath As String
    strPath = ThisWorkbook.Path & "\do\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xls*")
    Do While strExtension <> ""
        s = FileLastModified(strPath & strExtension)
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB.Sheets("ورقة1")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("A2:I" & LastRow).Copy
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End With
        End With
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
'MsgBox Round(Timer - t, 2)
End Sub
Function FileLastModified(StrFileName As String)
    Dim fs As Object, f As Object, s As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(StrFileName)
    s = UCase(StrFileName) & vbCrLf
    Set fs = Nothing: Set f = Nothing
End Function

 
عرض الإجابة




23-01-2021 01:30 مساء
مشاهدة مشاركة منفردة [1]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 237
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 34
قوة السمعة : 2349
عدد الإجابات: 31
 offline 
look/images/icons/i1.gif تعديل كود استدعاء من ملف مغلق الحلقة التكرارية تجعله ياخد وقت طويل جدااا
السلام عليكم ورحمة الله
جربى هذا الكود ربما يكون هذا ما تقصدين
Sub Trans1()
Dim ph As String
Dim wb As String
Dim Rng As String
Dim xx
t = Timer
Application.ScreenUpdating = False
ph = ThisWorkbook.Path & "\do\"
wb = "من" & ".xlsx"
Rng = "A1:G10000"
    ' ازالة كل البيانات بالشبت الحالى
Sheets("ورقة1").Range("A2:G10000").ClearContents
    'تسمية المسار الذى سيتم جلبه
xx = "='" & ph & "[" & wb & "]" & "'!" & Rng
    ' جلب البيانات و تحديد عدد الصفوف والاعمدة المطلوبة
With Sheets("ورقة1").Range("A2").Resize(10000, 7)
.Value = xx
     ' ازالة المعادلات و الاحتفاظ بقيمها
.Value = .Value
End With
     ' الغاء القيم الصفرية
ActiveWindow.DisplayZeros = False
Application.ScreenUpdating = True
'MsgBox Round(Timer - t, 2)
End Sub

23-01-2021 01:57 مساء
مشاهدة مشاركة منفردة [2]
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 
look/images/icons/i1.gif تعديل كود استدعاء من ملف مغلق الحلقة التكرارية تجعله ياخد وقت طويل جدااا
اتقدم اليك استاذ ابراهيم بخالص الامنيات الطيبة والدعوات الصالحة
المشكلة التى قابلتنى بكود حضرتك  الرائع هى انه يطلب من خلال شاشة البراوز تحديد اسم الملف ومكانه
وانا احتاج لتنفيذ والملف مغلق 
ارجو مساعدتى فى تعديل الكود بالاعلى هو يعمل ويستدعى والملف مغلق دون تحديده او تحديد اسمه المشكلة التى واجهتنى هو انه يتأخر جداااااااااا عند زيادة عدد الصفوف
بياخد وقت طويل جدا لتنفيذ الكود نظرا لوجود حلقتين تكرايتين
هل بالإمكان استاذ ابراهيم المحافظة على التنسيق من الملف المنقول منه إلى الملف الذي سيتم فيه النسخ 
حيث أن الملف الذي سيتم الاستدعاء منه به تنسيقات تكست وتاريخ وهكذا هل من إضافة الكود للمحافظة على نفس التنسيق
مع الشكر والدعاء
 
Is it possible for Mr. Ibrahim to preserve the format from the file from which he was transferred to the file in which the copying will take place? Since the file from which the call will be made has the text, date, and so on formats, and so on, is it necessary to add the code to keep the same format? With thanks and supplication God bless you, Professor Ibrahim
 
 
Is it possible for Mr. Ibrahim to preserve the format from the file from which he was transferred to the file in which the copying will take place? Since the file from which the call will be made has the text, date, and so on formats, and so on, is it necessary to add the code to keep the same format? With thanks and supplication
 

25-01-2021 03:06 مساء
مشاهدة مشاركة منفردة [3]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 237
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 34
قوة السمعة : 2349
عدد الإجابات: 31
 offline 
look/images/icons/i1.gif تعديل كود استدعاء من ملف مغلق الحلقة التكرارية تجعله ياخد وقت طويل جدااا
السلام عليكم ورحمة الله
ربما يفيدك هذا الكود 
هذا و الله اعلى و اعلم
Sub CopyRange()
t = timr
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.DisplayClipboardWindow = False
    Dim desWS As Worksheet, srcWB As Workbook, s As String
    Set desWS = ThisWorkbook.Sheets("ورقة1")
    Dim LastRow As Long
'   Const strPath As String = "E:\ClosedFiles\افضل حل\do\"
    Dim strPath As String
    strPath = ThisWorkbook.Path & "\do\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xls*")
    Do While strExtension <> ""
        s = FileLastModified(strPath & strExtension)
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB.Sheets("ورقة1")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("A2:I" & LastRow).Copy
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End With
        End With
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
'MsgBox Round(Timer - t, 2)
End Sub
Function FileLastModified(StrFileName As String)
    Dim fs As Object, f As Object, s As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(StrFileName)
    s = UCase(StrFileName) & vbCrLf
    Set fs = Nothing: Set f = Nothing
End Function

 

25-01-2021 04:30 مساء
مشاهدة مشاركة منفردة [4]
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 
look/images/icons/i1.gif تعديل كود استدعاء من ملف مغلق الحلقة التكرارية تجعله ياخد وقت طويل جدااا
رائع جدا سلمت يمينك هذا المطلوب والله نعجز عن شكر حضرتك فعلا رائع فرج الله همك

والبسك لباس الصحة والعافية دوما اشكرك استاذ ابراهيم الحداد



الكلمات الدلالية
تعديل ، استدعاء ، مغلق ، الحلقة ، التكرارية ، تجعله ، ياخد ، طويل ، جدااا ،


 










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

الساعة الآن 06:50 مساء