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

الترحيل بواسطة الكود

toyota

بواسطه toyota
في منتدى الاكسيل Excel

 مشاركة

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

toyota

toyota

قام بنشر
قام بنشر (معدل)

الاخوة الافاضل عباقره هذا المنتدي الرائع

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

مثال :

جميع قيود المكتب تجمع في شيت خاص بالمكتب

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

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

ورمضان كريم

Book2.zip

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

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

قام بنشر
قام بنشر

ما رايك ان تمييز أكواد المكتب عن اكواد البنك

مثلا يبدى كود البنك ب 99 وكود المكتب ب 33

لتسهيل الترحيل

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

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

قام بنشر
قام بنشر

السلام عليكم

جرب هذا الكود


Sub Abu_Ahmed()

Dim cl As Range

Application.ScreenUpdating = False

Set Mysh1 = Sheets("مكتب")

Set Mysh2 = Sheets("بنك")

For Each cl In [B3:B40]

If IsNumeric(cl) Then

Select Case Mid(cl, 1, 2)

Case Is = 99

cl.Offset(0, -1).Resize(1, 7).Copy

Mysh1.Range("A" & Mysh1.[A1000].End(xlUp).Row + 1).PasteSpecial xlPasteValues

	 Case Is = 33

	 cl.Offset(0, -1).Resize(1, 7).Copy

	 Mysh2.Range("A" & Mysh2.[A1000].End(xlUp).Row + 1).PasteSpecial xlPasteValues

End Select

End If

Next

Application.ScreenUpdating = True

Application.CutCopyMode = False

Set Mysh1 = Nothing

Set Mysh2 = Nothing

End Sub

Book2.rar

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

toyota

قام بنشر
  • الكاتب
قام بنشر

غزيزي الغالي شكرا لمجهودك

ولكن يبدو انني لم استطيع ايصال المعلومة بالشكل المطلوب

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

لقد وجد كود يعمل بصورة جيده كما اريد هل يمكن تطبيقه علي المثال الخاص بي ولك جزيل الشكر

----------------------------------------------------------------------------------------------------------------------------------------

Sub Excel4Us()

'www.Excel4us.com

'اول موقع عربي متخصص في الإكسيل

' مع تحيات اخوكم في الله : يحيى حسين

Application.ScreenUpdating = False

Dim i As Range, LR As Long, ws As Worksheet, wb As Workbook, C As Range

LR = Range("A" & Rows.Count).End(xlUp).Row

Sheets("sheet1").Range("d1:d" & LR).AdvancedFilter xlFilterCopy, copytorange:=Range("h1"), unique:=True

For Each C In Range("h2:h" & Range("h" & Rows.Count).End(xlUp).Row)

On Error GoTo 1

Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = C.Value

Next C

1

For Each C In Sheets("sheet1").Range("h2:h" & Sheets("sheet1").Range("h" & Rows.Count).End(xlUp).Row)

Sheets("sheet1").Range("a1:d1").AutoFilter field:=4, Criteria1:=C.Value

Sheets("sheet1").Range("a1:d" & Sheets("sheet1").Range("a" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy

For Each ws In ThisWorkbook.Worksheets

If ws.Name = C.Value Then

ws.Range("a1").PasteSpecial xlPasteColumnWidths

ws.Range("a1").PasteSpecial xlValue

ws.Range("a1").PasteSpecial xlPasteFormats

ws.DisplayRightToLeft = True

End If

Next ws

Sheets("sheet1").Range("a1:d1").AutoFilter

Application.CutCopyMode = False

Next C

Sheets("sheet1").Columns("h").Delete

Sheets("sheet1").Select

Application.ScreenUpdating = True

End Sub

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

رجب جاويش

قام بنشر
قام بنشر

أخى الفاضل جرب هذا الكود


Sub ragab()

Dim cl As Range, sh As Worksheet

Application.ScreenUpdating = False

For Each sh In ThisWorkbook.Worksheets

If Not sh.Name = "Sheet1" Then

sh.Range("A1:G1000").ClearContents

End If

Next

LR = Cells(Rows.Count, 2).End(xlUp).Row

For Each cl In Range("B2:B" & LR)

x = Trim(cl.Value)

On Error Resume Next

If Worksheets(x) Is Nothing Then

Sheets.Add.Name = x

Sheets(x).Move After:=Sheets(Sheets.Count)

End If

Sheets("sheet1").Range("A1:G1").Copy

Sheets(x).Range("A1").PasteSpecial xlPasteValues

Sheets(x).Range("A1").PasteSpecial xlPasteFormats

cl.Offset(0, -1).Resize(1, 7).Copy

Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues

Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteFormats

Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteColumnWidths

Application.CutCopyMode = False

Next

MsgBox "تم الترحيل بنجاح الى صفحات منفصلة"

Sheets("sheet1").Select

Application.ScreenUpdating = False

End Sub

كود ترحيل.rar

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

ahmd_asd4

قام بنشر
قام بنشر

ترحيل الطلاب ش ط بالكود التنسيق الجديدش ط.rar

الأخوة الأساتذة الأجلاء كل عام و أنتم بخير بعد التحية

فأنا طفل أحبو متعلما في هذا المنتدى العملاق

برجاء المساعدة في الملف الرفق فهو تنسيق عملته لمدرستي لتوزيع الطلاب على الأقسام

أريد بعد إزنكم : رؤية كود الترحيل فهو في الأساس للأستاذ الخبير جدا خبور و قمت فيه بما سترونه من تركيب ( عك مني )

1- ترحيل الطلاب حسب التخصصات في العمود 4 من صفحة الشيت

2- عمل زر بالضغط عليه يقوم بعمنلية الترحيل

3- تكون عملية الترحيل مرنة بحيث ممكن أن أمسح و أعيد الترحيل أكثر من مرة كما في كود الأستاذ خبور الأصلي

أسف للإطالة عليكم و لكن أعرف سعة صدوركم فهي من شيمة العلماء

رابط هذا التعليق
شارك
احمد حجازى

احمد حجازى

قام بنشر
قام بنشر

Sub ahmed()

Application.ScreenUpdating = False

Dim sh As Worksheet

For Each sh In ThisWorkbook.Worksheets

For r = 8 To 300

If sh.Name = "Sheet1" Then GoTo 2

If Cells(r, 5).Value <> Empty Then

If Cells(r, 5).Value = sh.Name Then

Range(Cells(r, 1), Cells(r, 13)).Copy

QQ = sh.Cells(1000, 1).End(xlUp).Row + 1

sh.Range("a" & QQ).PasteSpecial xlPasteValues

End If

End If

Next

2

Next

Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub

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

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

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



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept