اذهب الي المحتوي
أوفيسنا

تصحيح كود


إذهب إلى أفضل إجابة Solved by حسونة حسين,

الردود الموصى بها

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

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

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.xlsb

رابط هذا التعليق
شارك

ربما

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

 

  • Like 1
رابط هذا التعليق
شارك

image.png.f4b2220588a234ab4a10555a74cc89c9.png

1 ساعه مضت, حسونة حسين said:

ماذا تقصد ؟

 

1 ساعه مضت, محي الدين ابو البشر 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

 

image.png.f4b2220588a234ab4a10555a74cc89c9.png

رابط هذا التعليق
شارك

  • أفضل إجابة

تفضل اخى

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

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

  • Like 2
رابط هذا التعليق
شارك

3 ساعات مضت, حسونة حسين said:
        LastRow6 = Application.Max(3, Sht6.Cells(Rows.Count, 1).End(xlUp).Row + 1)

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

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

رابط هذا التعليق
شارك

3 ساعات مضت, محي الدين ابو البشر 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
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

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

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

بعد عملية الترحيل
اريد ترحيل بعض الاعمدة من هذه البيانات المجمعة في الصفحة 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

عسى ولعل

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

تم تعديل بواسطه محي الدين ابو البشر
  • Like 3
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information