من مصنف خارجي ضم الأسماء في ورقة واحدة

[ابوخليل]

السلام عليكم ورحمة الله وبركاته  وبعد :

اخواني الكرام

لا اعلم ان كان هذا الموضوع قد تطرق اليه ام لا ؟ علما اني وجدت موضوعا يتحدث عن جمع عدة ورقات في ورقة واحدة ولكنها تختلف عن الطريقة التي اريدها في التنفيذ .

 

1- اريد جميع الاسماء الموجودة في الورقات في المرفق Book1 ان تضم الى الورقة الأولى مع ادراج رقم الصف ورقم الفصل  كما هو موضح في الورقة الأولى والثانية .

2- واريد ان يتم تنفيذ العملية من الزر الموجود في Book2

 

وجزاكم الله خيرا

Downloads.rar

[ابوخليل]

2- واريد ان يتم تنفيذ العملية من الزر الموجود في Book2

 

سأغير الطلب اعلاه اذا لم يمكن  تحقيقه .

 

فيكون المطلوب : جلب نتيجة العملية  الى Book2   

[أبو حنــــين]

السلام عليكم

اخي ابو خليل

هذه مجرد محاولة لكنها تتطلب التعديل

 

Compressed.rar

[عبدالله باقشير]

السلام عليكم

 

وهذه محاولة حسب ما فهمت

 

المرفق 2003

ابو خليل.rar

[ابوخليل]

اعتذر لأساتذتي الفضلاء عن تقصيري في ايضاح المسألة.

وقد وقعت في الذي كنت انبه اخواني اليه  وهو ان ضبط واتقان السؤال = نصف الاجابة

1- اريد جميع الاسماء الموجودة في الورقات في المرفق Book1 ان تضم الى الورقة الأولى مع ادراج رقم الصف ورقم الفصل  كما هو موضح في الورقة الأولى والثانية .

 

  

والخطأ الذي وقعت فيه انني وضحت في الورقة الاولى والثانية ( الصف ، والفصل ) وهي في الاصل غير موجودة

حيث ان الصف والفصل موجودان اعلى الورقة في  ( C6) ، (C14 )

مع ملاحظة ان الصف  نص وليس رقم  واريد بعد الترحيل تحويله الى رقم ، وقد وضحت ذلك في المرفقات

 

في المرفقات المصنف الاصل book1 كما هو ، وبرفقه المطلوب

 

وجزاكم الله خيرا

ابو خليل2.rar

[أبو حنــــين]

اخي ايو خليل

جرب الملف و ان كان هناك بعض الملاحظات اذكرها لي

ابو خليل3.rar

[ابوخليل]

 

ما شاء الله لا قوة الا بالله

عمل متقن ولا اجمل ولا اروع

جزاك الله خيرا

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

 

استاذي وأخي الحبيب ابو حنين

حيث انك اذنت لي في ذكر الملاحظات فلدي استفسارين  : 

فان وجدت لديك الوقت الكافي والا فأنت في حل  من ذلك

 

الاول : حين اطلعت على الوحدة النمطية وجدت الورقات قد اثبت  بأسمائها

Dim Art
Art = Array("Sheet17", "Sheet16", "Sheet15", "Sheet14", "Sheet13", "Sheet12", _
"Sheet11", "Sheet10", "Sheet9", "Sheet8", "Sheet7", "Sheet6", _
"Sheet5", "Sheet4", "Sheet3", "Sheet2", "Sheet1")

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

 

 

 

. بارك الله في عمرك  و علمك 

[عبدالله باقشير]

السلام عليكم

جزاكم الله خيرا

 

هذا تعديل بسيط على الكود السابق ليناسب طلبك

Const wName As String = "Book1"
Sub kh_Trheel()
Dim xl As New Excel.Application
Dim wo As Workbook
Dim sh As Worksheet
Dim Ary()
Dim Lr As Long, r As Long, i As Long
On Error GoTo 1

Range("A1").Resize(Cells(Rows.Count, "A").End(xlUp).Row, 4).ClearContents

Set wo = xl.Workbooks.Open(ThisWorkbook.Path & "\" & wName & ".xls")

For Each sh In wo.Worksheets
    With sh
        Lr = .Cells(Rows.Count, "Q").End(xlUp).Row
        For r = 23 To Lr
            i = i + 1
            ReDim Preserve Ary(1 To 4, 1 To i)
            Ary(1, i) = i
            Ary(2, i) = .Cells(r, "Q").Value
            Ary(3, i) = .Range("C6").Value
            Ary(4, i) = .Range("C14").Value
        Next
    End With
Next
If i Then
    Range("A1").Resize(i, 4).Value = WorksheetFunction.Transpose(Ary)
End If
1:
If Not wo Is Nothing Then wo.Close False
Set wo = Nothing
Erase Ary
End Sub

تحياتي

[ابوخليل]

روعة  .. سلمت أناملك

وجزاك الله  خيرا

وللتنبيه فان المرفق السابق لم يعمل معي

 

وبقي استاذي الاستفسار الثاني ولعله الاخير

وهو كيف ابني عمودا رقميا الى جانب الاعمدة الناتجة يمثل الصفوف  من 1 الى 6  فالاول الابتدائي يقابله رقم 1  والثاني الابتدائي 2  ..... وهكذا الى الصف السادس 6

لاني اريد ان اتعامل مع الصف كرقم

 

بارك الله في علمك وعملك

[عبدالله باقشير]

السلامعليكم

 

جزاكم الله خيرا

 

بالنسبة لطلبك جرب الكود التالي وبامكانك تغير اماكن الاعمدة من الكود

Const wName As String = "Book1"
Const ContColumn As Integer = 5
Const Txt As String = "الأول الابتدائي-الثاني الابتدائي-الثالث الابتدائي-الرابع الابتدائي-الخامس الابتدائي-السادس الابتدائي"

Sub kh_Trheel()
Dim xl As New Excel.Application
Dim wo As Workbook
Dim sh As Worksheet
Dim Ary()
Dim Lr As Long, r As Long, i As Long

On Error Resume Next


Range("A1").Resize(Cells(Rows.Count, "A").End(xlUp).Row, ContColumn).ClearContents

Set wo = xl.Workbooks.Open(ThisWorkbook.Path & "\" & wName & ".xls")

For Each sh In wo.Worksheets
    With sh
        Lr = .Cells(Rows.Count, "Q").End(xlUp).Row
        For r = 23 To Lr
            i = i + 1
            ReDim Preserve Ary(1 To ContColumn, 1 To i)
            Ary(1, i) = i
            Ary(2, i) = .Cells(r, "Q").Value
            Ary(3, i) = .Range("C6").Value
            Ary(4, i) = .Range("C14").Value
            Ary(5, i) = WorksheetFunction.Match(CStr(.Range("C6")), Split(Txt, "-"), 0)
        Next
    End With
Next
If i Then
    Range("A1").Resize(i, ContColumn).Value = WorksheetFunction.Transpose(Ary)
End If
1:
If Not wo Is Nothing Then wo.Close False
Set wo = Nothing
Erase Ary
On Error GoTo 0
End Sub

تحياتي

[ابوخليل]

وفيت وكفيت ،،،

أحسن الله اليك .