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

[ابوزينب]

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

[الـعيدروس]

ممكن ليش لا إرفق ملف

وماهو المدى في كل الشيتات

[ابوزينب]

ارفق لكم الملف ولكن كيف ارفق الملف

[الـعيدروس]

اخي الفاضل عند كلمة اضف الرد تلاقي كلمة (استخدام المحرر الكامل) انقر عليها

ويجيك زر (اختار ملف) انقر عليه وحدد مكان الملف المراد ارفاقه

ومن ثم إضغط موافق وبعدها تحت زر (اختار ملف) تلاقي زر (ارفق هذا الملف ) انقر عليه

وبعده اضغط (اضف الرد)

بالتفصيل الممل

[ابوزينب]

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

1.rar

[عبدالله المجرب]

الملف الكتابة فيه معكوسة

نرجو اعادة ارفاق ملف صحيح

==

وكيف تريد جمعهم (ما المطلوب بالضبط)

[ابوزينب]

ياأخى لا يهم الكتابة المعكوسة انا اريد البيانات تأتى تحت بعضها حتى يكونوا ورقة واحدة

[عبدالله المجرب]

جرب المرفق بعد التعديل

Sub Abu_ahmed()

Range("B2:B10000").ClearContents

For i = 2 To Sheets.Count

For j = 2 To Sheets(i).Range("A" & Rows.Count).End(xlUp).Row

Cells(Range("B" & Rows.Count).End(xlUp).Row + 1, 2).Value = Sheets(i).Cells(j, 1).Value

Next

Next

End Sub

1 (1).rar

[ابوزينب]

بارك الله فيك ياأخى جهد مشكور ولكن لما جربت جاب الاسماء دون الرقم

[عبدالله المجرب]

اخي الرقم هو رقم تسلسلي

يمكنك عمله يدوي او بامكانك ان تضع دالة تسلسل تلقائي

[عبدالله المجرب]

وان كانت تريد التسلسل المكتوب مسبقاً فسيكون الكود كالتالي

Sub Abu_ahmed()

Range("A2:B10000").ClearContents

For i = 2 To Sheets.Count

For j = 2 To Sheets(i).Range("A" & Rows.Count).End(xlUp).Row

Cells(Range("B" & Rows.Count).End(xlUp).Row + 1, 2).Value = Sheets(i).Cells(j, 1).Value

Cells(Range("B" & Rows.Count).End(xlUp).Row, 1).Value = Sheets(i).Cells(j, 2).Value

Next

Next

End Sub

[الـعيدروس]

السلام عليكم

جزاك الله خير استاذ احمد على الكود المختصر

بعد اذن استاذنا الحبيب لتعدد الحلول

اخي الفاضل بأمكانك الاستعانه بهذا الكود

يقوم بإنشاء ورقة جديدة وتسميتها SUM_DATA_ALI

ويلصق جميع بيانات الأوراق فيها

Sub Cop_A()

Dim WRK_A As Workbook

Dim SH_A, TG_A As Worksheet

Dim RG_A As Range

Dim C_CT As Integer

Set WRK_A = ActiveWorkbook

For Each SH_A In WRK_A.Worksheets

If SH_A.Name = "SUM_DATA_ALI" Then

MsgBox "وجود إسم ورقة تجميع البيانات مسبقا 'SUM_DATA_ALI'" & vbCrLf & _

"برجاء تغير الإسم أو حذف الورقة", vbOKOnly + vbExclamation, "تحذير !!!"

Exit Sub

End If

Next SH_A


   Application.ScreenUpdating = False

   Set TG_A = WRK_A.Worksheets.Add(After:=WRK_A.Worksheets(WRK_A.Worksheets.Count))

   TG_A.Name = "SUM_DATA_ALI"

	    Set SH_A = WRK_A.Worksheets(1)

	    C_CT = SH_A.Cells(1, Columns.Count).End(xlToLeft).Column

	    With TG_A.Cells(1, 1).Resize(1, C_CT - 1)

			    .Value = SH_A.Cells(1, 1).Resize(1, C_CT - 1).Value

	    End With

	    For Each SH_A In WRK_A.Worksheets

			    If SH_A.Index = WRK_A.Worksheets.Count Then

					    Exit For

			    End If

					    Set RG_A = SH_A.Range(SH_A.Cells(2, 1), SH_A.Cells(Rows.Count, 2).End(xlUp).Resize(, C_CT - 1))

					    TG_A.Cells(Rows.Count, 2).End(xlUp).Offset(1).Resize(RG_A.Rows.Count, RG_A.Columns.Count).Value = RG_A.Value

					    TG_A.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(RG_A.Rows.Count, 1).Value = SH_A.Name

			    TG_A.Cells(1, 1) = "Sheet Name": TG_A.Cells(1, 2) = SH_A.Cells(1, 1): TG_A.Cells(1, 3) = SH_A.Cells(1, 1).Offset(0, 1)

		  TG_A.Cells(1, 1).Resize(1, 3).Borders.Color = 1: TG_A.Cells(1, 1).Resize(1, 3).Font.Bold = True

	    TG_A.Columns.AutoFit

	    Next SH_A

	    Application.ScreenUpdating = True

End Sub