basnt قام بنشر أغسطس 28 مشاركة قام بنشر أغسطس 28 السلام عليكم بعد إذن الجميع ده ملف اكسيل مكتوب في الشيت الأول المطلوب بعد إذنكو عند الضغط على ترحيل يتم ترحيل البيانات بشرط يظهرلى input box اكتب فيه الشهر المرحل منه ثم يظهر input box اكتب فيه الشهر المرحل اليه ويتم الترحيل من والى العمود b5:b200 فى كل الشهور ترحيل.xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر أغسطس 28 أفضل إجابة مشاركة قام بنشر أغسطس 28 وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا بمكنك حدف السطور المخصصة للتحقق من أوراق العمل في حالة الرغبة لاختصار الكود Sub test1() Dim DataRng As Range, arr As Variant Dim Ct As Long, i As Long, tmp As Boolean Dim ws As Worksheet, dest As Worksheet Dim WSname As String, destName As String '****التحقق من وجود ورقة العمل المرغوب الترحيل منها WSname = InputBox(" : يرجى إدخال اسم الشهر المرغوب ترحيله") If Len(Trim(WSname)) = 0 Then MsgBox " تم إلغاء الترحيــل", vbExclamation Exit Sub End If On Error Resume Next Set ws = ThisWorkbook.Sheets(WSname) On Error GoTo 0 If ws Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If '****التحقق من وجود ورقة العمل المرغوب الترحيل اليها destName = InputBox(" : يرجى إدخال اسم الشهر المرحل إليه") If Len(Trim(destName)) = 0 Then MsgBox " تم إلغاء الترحيــل", vbExclamation Exit Sub End If On Error Resume Next Set dest = ThisWorkbook.Sheets(destName) On Error GoTo 0 If dest Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If '***** نطاق البيانات Set DataRng = ws.Range("B5:B200") tmp = Application.WorksheetFunction.CountA(DataRng) > 0 If Not tmp Then MsgBox WSname & " " & "لا يوجد بيانات للنسخ في شهر", vbExclamation Exit Sub End If '****افراغ البيانات السابقة dest.Range("B5:B200").ClearContents ReDim arr(1 To DataRng.Rows.Count, 1) Ct = 0 For i = 1 To DataRng.Rows.Count If Len(DataRng.Cells(i, 1).Value) > 0 Then Ct = Ct + 1 arr(Ct, 1) = DataRng.Cells(i, 1).Value End If Next i ' لصق البيانات بداية من الصف 5 من ورقة الشهر المختارة If Ct > 0 Then For i = 1 To Ct dest.Range("B5").Offset(i - 1, 0).Value = arr(i, 1) Next i End If MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى " & "شهر" & " " & destName & " " & " بنجاح", vbInformation End Sub ولنسخها بدون تكرار ستجد الكود داخل الملف المرفق ترحيل.xlsm 2 1 رابط هذا التعليق شارك More sharing options...
basnt قام بنشر أغسطس 29 الكاتب مشاركة قام بنشر أغسطس 29 أستاذ محمد هشام بارك الله فيك حضرتك راجل محترم 1 رابط هذا التعليق شارك More sharing options...
basnt قام بنشر سبتمبر 2 الكاتب مشاركة قام بنشر سبتمبر 2 هل يمكن ترحيل بدون تكرار من اكثر من عمود مثلا في الكود إلي حضرتك بعته الترحيل من b5:b200 يمكن اضافه من c5:c200 اوd5:d200 مثلا ولك جزيل الشكر رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر سبتمبر 2 مشاركة قام بنشر سبتمبر 2 نعم من الممكن فعل دالك لاكنك لم توضح هل البيانات الخاصة بالاعمدة المحددة هل سيتم نسخها بدون تكرار الى عمود b اسفل بعضها البعض او يجب نسخ بيانات كل عمود مستقل الى الورقة الهدف في نفس العمود كما في المثال السابق رابط هذا التعليق شارك More sharing options...
basnt قام بنشر سبتمبر 2 الكاتب مشاركة قام بنشر سبتمبر 2 نسخ كل عمود مستقل الي الورقه الهدف في نفس العمود مع امكانيه تغيير الاعمده المرحل إليها بمعني ترحيل الاعمده b5:b200و c5:c200 و d5:d200 الي ورقه الهدف إما إلي نفس الاعمده او غيرها أي أقوم بتعديلها بنفسي في الكود يعني كود اقدر اغير في الاعمده المرحل منها وإليها رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر سبتمبر 3 مشاركة قام بنشر سبتمبر 3 تمام اخي بما أن الموضوع مختلف حاول فتح موضوع جديد بطلبك وإن شاء الله سنقوم بإنشاء أو تعديل الكود ليتناسب مع متطلباتك الجديدة بالتوفيق .. رابط هذا التعليق شارك More sharing options...
الردود الموصى بها