toyota قام بنشر أغسطس 2, 2012 مشاركة قام بنشر أغسطس 2, 2012 (معدل) الاخوة الافاضل عباقره هذا المنتدي الرائع اريد منكم المساعده في عمل ترحيل للبيانات الموجوده الملف المرفق بحيث ترحل كل بينات كود معين الي صفحة واحده مثال : جميع قيود المكتب تجمع في شيت خاص بالمكتب وجميع قيود البنك تجمع في شيت خاص بالبنك وهكذا ارجوا ان لا اكون قد اثقلت عليكم بطلبي هذا ورمضان كريم Book2.zip تم تعديل أغسطس 2, 2012 بواسطه toyota رابط هذا التعليق شارك More sharing options...
عبدالله المجرب قام بنشر أغسطس 2, 2012 مشاركة قام بنشر أغسطس 2, 2012 ما رايك ان تمييز أكواد المكتب عن اكواد البنك مثلا يبدى كود البنك ب 99 وكود المكتب ب 33 لتسهيل الترحيل رابط هذا التعليق شارك More sharing options...
toyota قام بنشر أغسطس 2, 2012 الكاتب مشاركة قام بنشر أغسطس 2, 2012 لا توجد مشكله وشكرا للاهتمامك رابط هذا التعليق شارك More sharing options...
عبدالله المجرب قام بنشر أغسطس 2, 2012 مشاركة قام بنشر أغسطس 2, 2012 السلام عليكم جرب هذا الكود 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 رابط هذا التعليق شارك More sharing options...
toyota قام بنشر أغسطس 2, 2012 الكاتب مشاركة قام بنشر أغسطس 2, 2012 غزيزي الغالي شكرا لمجهودك ولكن يبدو انني لم استطيع ايصال المعلومة بالشكل المطلوب انا اريد ان ترحل البيانات بدلاله الكود اي تذهب كل مجموعه من البيانات بكود متشابه الي صحفة مستلقة لانه يمكن ان تكون هناك اكواد جديد تستحدث لقد وجد كود يعمل بصورة جيده كما اريد هل يمكن تطبيقه علي المثال الخاص بي ولك جزيل الشكر ---------------------------------------------------------------------------------------------------------------------------------------- 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 رابط هذا التعليق شارك More sharing options...
toyota قام بنشر أغسطس 2, 2012 الكاتب مشاركة قام بنشر أغسطس 2, 2012 هذا هو الملف الذي يعمل عليه الكود السابق فرز الاسماء حسب النوع_2.zip رابط هذا التعليق شارك More sharing options...
رجب جاويش قام بنشر أغسطس 2, 2012 مشاركة قام بنشر أغسطس 2, 2012 أخى الفاضل جرب هذا الكود 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 رابط هذا التعليق شارك More sharing options...
toyota قام بنشر أغسطس 2, 2012 الكاتب مشاركة قام بنشر أغسطس 2, 2012 بارك الله فيك يا استاذ رجب وزادك الله من علمه لك مني كل الشكر والامنتنان رابط هذا التعليق شارك More sharing options...
رجب جاويش قام بنشر أغسطس 3, 2012 مشاركة قام بنشر أغسطس 3, 2012 شكرا جزيلا أخى الفاضل على هذه الكلمات الطيبة زكل عام وأنتم بخير رابط هذا التعليق شارك More sharing options...
ahmd_asd4 قام بنشر أغسطس 3, 2012 مشاركة قام بنشر أغسطس 3, 2012 ترحيل الطلاب ش ط بالكود التنسيق الجديدش ط.rar الأخوة الأساتذة الأجلاء كل عام و أنتم بخير بعد التحية فأنا طفل أحبو متعلما في هذا المنتدى العملاق برجاء المساعدة في الملف الرفق فهو تنسيق عملته لمدرستي لتوزيع الطلاب على الأقسام أريد بعد إزنكم : رؤية كود الترحيل فهو في الأساس للأستاذ الخبير جدا خبور و قمت فيه بما سترونه من تركيب ( عك مني ) 1- ترحيل الطلاب حسب التخصصات في العمود 4 من صفحة الشيت 2- عمل زر بالضغط عليه يقوم بعمنلية الترحيل 3- تكون عملية الترحيل مرنة بحيث ممكن أن أمسح و أعيد الترحيل أكثر من مرة كما في كود الأستاذ خبور الأصلي أسف للإطالة عليكم و لكن أعرف سعة صدوركم فهي من شيمة العلماء رابط هذا التعليق شارك More sharing options...
احمد حجازى قام بنشر أغسطس 4, 2012 مشاركة قام بنشر أغسطس 4, 2012 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 رابط هذا التعليق شارك More sharing options...
احمد حجازى قام بنشر أغسطس 4, 2012 مشاركة قام بنشر أغسطس 4, 2012 الكود المرفق فوق هذا الموضوع ....اريد فيه تعديل بحيث يرحل اعمده معينه وترك اعمده اخرى وليست ترحيل كل الاعمده ...............ارجو المساعده باسرع وقت ..وفقكم الله رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.