تصحيح كود

[علي المصري]

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

الكود التالي المفروض يقوم بدمج الصفحات الثلاثة  

B3DataT1, B2DataT1, B1DataT1

الي الصفحة  DataT1

ولكن لا يعمل بشكل صحيح

فهل من مساعدة لتصحيحه

Sub Merge_Sheets()

Dim Sht As Worksheet
Dim Sht6 As Worksheet
Dim LastRow6 As Long
Dim Rng As Range

Set Sht6 = Sheets("DataT1")

'Determine lastrow on DatatT1
LastRow6 = Sht6.Range("A" & Rows.Count).End(xlUp).Row

'Loop though B1DataT1 - B2DataT1 - B3DataT1
For Each Sht In Sheets(Array("B1DataT1", "B2DataT1", "B3DataT1"))

'Find last row
LastRow = Sht.Range("A" & Rows.Count).End(xlUp).Row

'Set Range
Set Rng = Sht.Range("A3:Q" & LastRow)

'Copy to DataT1
Rng.Copy Destination:=Sht6.Range("A3:Q" & LastRow6 + 2)

Next
End Sub

 

T1 --Data.xlsbFetching info...

[حسونة حسين]

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

عدل

Rng.Copy Destination:=Sht6.Range("A3:Q" & LastRow6 + 2)
الى
Rng.Copy Destination:=Sht6.Range("A" &  LastRow6 + 2 & ":Q" & LastRow6 + 2)

 

[علي المصري]

لا يعطي نتيجة

 

تم تعديل فبراير 14, 2023 بواسطه علي المصري

[حسونة حسين]

  في 14‏/2‏/2023 at 06:23, علي المصري said:

لا يعطي نتيجة

Expand  

ماذا تقصد ؟

[محي الدين ابو البشر]

ربما

Sub Merge_Sheets()

Dim Sht As Worksheet
Dim Sht6 As Worksheet
Dim LastRow6 As Long
Dim Rng As Range

Set Sht6 = Sheets("DataT1")

'Determine lastrow on DatatT1

x = Array("B1DataT1", "B2DataT1", "B3DataT1")
'Loop though B1DataT1 - B2DataT1 - B3DataT1
For i = 0 To UBound(x)
Set Sht = Sheets(x(i))
'Find last row
LastRow = Sht.Range("A" & Rows.Count).End(xlUp).Row

'Set Range
Set Rng = Sht.Range("A3:Q" & LastRow)
LastRow6 = Sht6.Cells(Rows.Count, 1).End(xlUp).Row
'Copy to DataT1
Rng.Copy Destination:=Sht6.Range("A" & LastRow6 + 2)

Next
End Sub

 

[علي المصري]

  في 14‏/2‏/2023 at 08:53, حسونة حسين said:

ماذا تقصد ؟

Expand  

 

  في 14‏/2‏/2023 at 09:12, محي الدين ابو البشر said:

ربما

Sub Merge_Sheets()

Dim Sht As Worksheet
Dim Sht6 As Worksheet
Dim LastRow6 As Long
Dim Rng As Range

Set Sht6 = Sheets("DataT1")

'Determine lastrow on DatatT1

x = Array("B1DataT1", "B2DataT1", "B3DataT1")
'Loop though B1DataT1 - B2DataT1 - B3DataT1
For i = 0 To UBound(x)
Set Sht = Sheets(x(i))
'Find last row
LastRow = Sht.Range("A" & Rows.Count).End(xlUp).Row

'Set Range
Set Rng = Sht.Range("A3:Q" & LastRow)
LastRow6 = Sht6.Cells(Rows.Count, 1).End(xlUp).Row
'Copy to DataT1
Rng.Copy Destination:=Sht6.Range("A" & LastRow6 + 2)

Next
End Sub

 

Expand  

[محي الدين ابو البشر]

T1 --Data.xlsmFetching info...

T1 --Data.xlsmFetching info...

تم تعديل فبراير 14, 2023 بواسطه محي الدين ابو البشر

[حسونة حسين]

تفضل اخى

Sub Merge_Sheets()
    Dim Sht As Worksheet
    Dim Sht6 As Worksheet
    Dim LastRow6 As Long
    Dim Rng As Range
    Set Sht6 = Sheets("DataT1")
    'Loop though B1DataT1 - B2DataT1 - B3DataT1
    For Each Sht In Sheets(Array("B1DataT1", "B2DataT1", "B3DataT1"))
        'Find last row
        LastRow = Sht.Range("A" & Rows.Count).End(xlUp).Row
        'Determine lastrow on DatatT1
        LastRow6 = Application.Max(3, Sht6.Cells(Rows.Count, 1).End(xlUp).Row + 1)
        'Set Range
        Set Rng = Sht.Range("A3:Q" & LastRow)
        'Copy to DataT1
        Rng.Copy Destination:=Sht6.Range("A" & LastRow6)
    Next
End Sub

ولا تنسي ان تمسح البيانات الموجوده في الشيت

Sht6

لان بها بيانات تتعدى ال ٣٠٠٠ السطر 

[saad abed]

السلام عليكم

يفضل اضافة سطر لمسح الداتا 

Sht6.Range("A3:Q100000").ClearContents

[علي المصري]

  في 14‏/2‏/2023 at 12:01, حسونة حسين said:

        LastRow6 = Application.Max(3, Sht6.Cells(Rows.Count, 1).End(xlUp).Row + 1)

Expand  

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

ثانيا ممكن شرح لهذا السطر من الكود

[علي المصري]

  في 14‏/2‏/2023 at 11:38, محي الدين ابو البشر said:

T1 --Data.xlsmUnavailable

T1 --Data.xlsm 455.61 kB · 9 downloads

Expand  

عند استخدام هذا الكود ظهر صف فارغ بين بيانات الصفة الاولى والثانية وهكذا

تم التغلب عليه عن طريق التعديل التالي

 

Sub Merge_Sheets()

Dim Sht As Worksheet
Dim Sht6 As Worksheet
Dim LastRow6 As Long
Dim Rng As Range

Set Sht6 = Sheets("DataT1")

'Determine lastrow on DatatT1

x = Array("B1DataT1", "B2DataT1", "B3DataT1")
'Loop though B1DataT1 - B2DataT1 - B3DataT1
For i = 0 To UBound(x)
Set Sht = Sheets(x(i))
'Find last row
LastRow = Sht.Range("A" & Rows.Count).End(xlUp).Row

'Set Range
Set Rng = Sht.Range("A3:Q" & LastRow)
LastRow6 = Sht6.Cells(Rows.Count, 1).End(xlUp).Row
'Copy to DataT1
If LastRow6 = 1 Then
Rng.Copy Destination:=Sht6.Range("A" & LastRow6 + 2)
Else
Rng.Copy Destination:=Sht6.Range("A" & LastRow6 + 1)
End If
Next
End Sub

مع الشكر الجزيل لحضرتك

تم تعديل فبراير 14, 2023 بواسطه علي المصري

[علي المصري]

بعد عملية الترحيل
اريد ترحيل بعض الاعمدة من هذه البيانات المجمعة في الصفحة DataT1 إلى صفحة جديدة اخرى اسمها مثلا  GradesT1

فكيف يكون شكل الكود

شكرا لكم

 

[محي الدين ابو البشر]

 Sub test()
 Dim a
 With Sheets("DataT1").Cells(1).CurrentRegion
 a = .Value
 With Sheets("GradesT1")
 .Cells(1, 1).Resize(UBound(a), 5) = Application.Index(a, Evaluate("row(1:" & UBound(a) & ")"), [{1,5,3,4,7}])
 End With: End With
 End Sub

عسى ولعل

تم نقل خمسة أعمدة وبالترتيب الذي تختاره أنت

تم تعديل فبراير 15, 2023 بواسطه محي الدين ابو البشر

[علي المصري]

  في 15‏/2‏/2023 at 07:32, محي الدين ابو البشر said:

عسى ولعل

 

Expand  

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

ومعذرة على تعبكم

[محي الدين ابو البشر]

بارك الله