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

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


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





كود دمج بيانات مجموعة مصنفات فى ورقة واحده

السلام عليكم هذا الكود لتجميع بيانات من مجموعة مصنفات ولكن عند سطر اللصق يقف الكود ممكن المساعده فى معرفة السبب وجزي ..


موضوع مغلق


20-05-2022 07:27 صباحا
adnan1417
عضو
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19313
المشاركات : 11
الجنس : ذكر
تاريخ الميلاد : 1-8-88
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 16
 offline 


السلام عليكم 
هذا الكود لتجميع بيانات من مجموعة مصنفات ولكن عند سطر اللصق يقف الكود  ممكن المساعده فى معرفة السبب 
وجزيتم خيرا 
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب


Sub test()
Dim i As Long, sh As Long, lr As Long, twh As Variant, awh As Variant
Dim r As Range, d As Range
Dim folder As String, filename As String
folder = "C:UsersascomDesktoptest"
filename = Dir(folder & "*.xlsx")
Set twh = ThisWorkbook
 Do
 If filename = "1.xlsx" Then
 filename = Dir
 Else
   Workbooks.Open folder & "" & filename
  Set awh = ActiveWorkbook
  Set r = ActiveWorkbook.Sheets("ورقة1").Range("a1").CurrentRegion
r.Offset(1, 0).Resize(Range("a1").CurrentRegion.Rows.Count - 1).Copy
ThisWorkbook.Sheets("shh").Activate
Range("a1").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial
ActiveSheet.Close savechanges:=False
 filename = Dir
  End If
 Loop Until filename = ""
 End Sub
 
 
  test.rar   تحميل rar مرات التحميل :(6)
الحجم :(44.359) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
وعليكم السلام
جرب الكود التالي 
Sub Test()
    Dim a, twh As Workbook, awh As Workbook, sh As Worksheet, myFolder As String, fn As String, lr As Long
    Application.ScreenUpdating = False
        myFolder = Environ("USERPROFILE") & "\Desktop\Test"
        Set twh = ThisWorkbook
        Set sh = twh.Worksheets("shh")
        fn = Dir(myFolder & "\*.xlsx")
        Do
            If fn = "1.xlsx" Then GoTo Skipper
            Workbooks.Open myFolder & "\" & fn
            Set awh = ActiveWorkbook
            a = awh.Sheets(1).Range("A1").CurrentRegion.Offset(1).Value
            lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
            sh.Range("A" & lr).Resize(UBound(a, 1), UBound(a, 2)).Value = a
            awh.Close SaveChanges:=False
Skipper:
            fn = Dir
        Loop Until fn = ""
    Application.ScreenUpdating = True
End Sub
عرض الإجابة




20-05-2022 07:49 صباحا
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif كود دمج بيانات مجموعة مصنفات فى ورقة واحده
وعليكم السلام
جرب الكود التالي 
Sub Test()
    Dim a, twh As Workbook, awh As Workbook, sh As Worksheet, myFolder As String, fn As String, lr As Long
    Application.ScreenUpdating = False
        myFolder = Environ("USERPROFILE") & "\Desktop\Test"
        Set twh = ThisWorkbook
        Set sh = twh.Worksheets("shh")
        fn = Dir(myFolder & "\*.xlsx")
        Do
            If fn = "1.xlsx" Then GoTo Skipper
            Workbooks.Open myFolder & "\" & fn
            Set awh = ActiveWorkbook
            a = awh.Sheets(1).Range("A1").CurrentRegion.Offset(1).Value
            lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
            sh.Range("A" & lr).Resize(UBound(a, 1), UBound(a, 2)).Value = a
            awh.Close SaveChanges:=False
Skipper:
            fn = Dir
        Loop Until fn = ""
    Application.ScreenUpdating = True
End Sub

21-05-2022 10:36 مساء
مشاهدة مشاركة منفردة [2]
adnan1417
عضو
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19313
المشاركات : 11
الجنس : ذكر
تاريخ الميلاد : 1-8-88
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 16
 offline 
look/images/icons/i1.gif كود دمج بيانات مجموعة مصنفات فى ورقة واحده
جزاك الله خيرا استاذ ياسر 

21-05-2022 11:49 مساء
مشاهدة مشاركة منفردة [3]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif كود دمج بيانات مجموعة مصنفات فى ورقة واحده
وجزيت خيراً أخي الكريم بمثل ما دعوت لي وزيادة
والحمد لله الذي بنعمته تتم الصالحات



الكلمات الدلالية
بيانات ، مجموعة ، مصنفات ، ورقة ، واحده ،


 










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

الساعة الآن 05:48 مساء