ترحيل بيانات حسب رقم الشيت

[حسين مامون]

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

اخواني اريد ترحيل بيانات من الشيت "الرءيسية " الى الصفحات المرقمة الموضوت شرحته في المرفق

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

Copie de الترحيل حسب رقم الشيت.zip

تم تعديل أغسطس 4, 2016 بواسطه حسين22
ارفاق النمودج

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

السلام عليكم

جرب هذا الكود 

Sub CopyToSheets()

	Application.ScreenUpdating = False
	Dim i As Integer, sh As Worksheet, HS As Worksheet, Lr As Integer, iLr As Integer
	Set sh = Sheets("ÇáÑÆíÓíÉ")
With sh
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Lr 'Sheets.Count
For Each HS In Sheets
	If HS.Name = sh.Cells(i, 1) Then
	iLr = HS.Cells(Rows.Count, 1).End(xlUp).Row + 1
	sh.Range("A" & i).Resize(, 7).Copy
	HS.Range("A" & iLr).PasteSpecial (xlPasteValues)
End If
Next
Next
End With
	Application.ScreenUpdating = True
	Application.CutCopyMode = False

End Sub

 

[حسين مامون]

شكرا استاد ساجرب انشاء الله

[حسين مامون]

السلام عليكم

استاد الكود يعمل انه راءع حفظك الله ورعاك 

تعديل بسيط في الكود 

اريد افراغ البيانات من الرءيسية بعد الترحيل

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

لمسح المحتويات  

Sub CopyToSheets()

    Application.ScreenUpdating = False
    Dim i As Integer, sh As Worksheet, HS As Worksheet, Lr As Integer, iLr As Integer
    Set sh = Sheets("الرئيسية")
With sh
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Lr 'Sheets.Count
For Each HS In Sheets
    If HS.Name = sh.Cells(i, 1) Then
    iLr = HS.Cells(Rows.Count, 1).End(xlUp).Row + 1
    sh.Range("A" & i).Resize(, 7).Copy
    HS.Range("A" & iLr).PasteSpecial (xlPasteValues)
End If
Next
Next
.Range("A2:G" & Lr).ClearContents
End With
    Application.ScreenUpdating = True
    Application.CutCopyMode = False

End Sub

 

[حسين مامون]

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

هل يمكن اضافة msgboxعند الترحيل الى رقم غير موجد يتوقف الترحيل 

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

[سليم حاصبيا]

بعد اذن الاخ ابو حنين هذا الكود ربما يكون اسرع قليلاً

Sub transpos_data()
Dim Sh_Principal As Worksheet
Dim lr As Integer
Dim my_row As Integer
Set Sh_Principal = Sheets("الرئيسية")
Dim My_rg As Range

lr = Sh_Principal.Cells(Rows.Count, 1).End(3).Row
 For I = 3 To Sheets.Count
   my_row = Sheets(I).Cells(Rows.Count, 1).End(3).Row
'    Sheets(I).Range("a4:G" & my_row).ClearContents
    Sh_Principal.Range("a1").AutoFilter field:=1, Criteria1:=Sheets(I).Name
  Set My_rg = Sh_Principal.Range("a2:g" & lr).SpecialCells(12)
   my_row = Sheets(I).Cells(Rows.Count, 1).End(3).Row
    If my_row < 4 Then my_row = 4
    If my_row = 4 Then
  My_rg.Copy Destination:=Sheets(I).Range("A4")
    Else
    My_rg.Copy Destination:=Sheets(I).Range("A" & my_row + 1)
    End If
    Next
    
End Sub

 

[حسين مامون]

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

استاد سليم اشكرك هذا الكود لايعمل كما اريد  

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

  الكود الاول لاستاد ابو حنين يعمل جيدا كما اريد  وارحل به 251 بيان في ظرف وجيز

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

شكرا لكم يا اساتدتنا الاعزاء

 

 

 

 

 

تم تعديل أغسطس 5, 2016 بواسطه حسين22