أبو عبد الله _ قام بنشر فبراير 22, 2022 مشاركة قام بنشر فبراير 22, 2022 السلام عليكم أعضاء المنتدى الكرام بحثت فى المنتدى قبل عرض الموضوع لكن لم أتمكن من الوصول لما أريد المطلوب ترحيل بيانات اعتمادا على خلايا متفرقة والتوضيح داخل الملف المرفق المعرض الخيري.xlsx رابط هذا التعليق شارك More sharing options...
أبو عبد الله _ قام بنشر فبراير 23, 2022 الكاتب مشاركة قام بنشر فبراير 23, 2022 إذا تعذر العمل على البيانات بشكل أفقي يمكن التعا مل معها بشكل رأسي ( أعمدة ) مع ملاحظة : انه يتم ادخال جميع الارقام ثم الترحيل المعرض الخيري رأسي.xlsx رابط هذا التعليق شارك More sharing options...
أبو عبد الله _ قام بنشر فبراير 23, 2022 الكاتب مشاركة قام بنشر فبراير 23, 2022 اذا كان الامر غير ممكن . هل يمكن تعديل المعادلة التالية والخاصة بالترحيل وأنا سوف أقوم بتوظيفها إن شاء الله =IF(COUNTIF(الطـلاب!$B$4:$B$1504;"اضافة")<ROWS(A$2:A2);"";INDEX(الطـلاب!$E$4:$E$1504;100000-SUMPRODUCT(LARGE((الطـلاب!$B$4:$B$1504="اضافة")*(100000-ROW(الطـلاب!$B$4:$B$1504));ROWS(A$2:A2)))-3)) هنا كما هو واضح يتم تحيل البيانات إذا وجدت كلمة إضافة في العمود B .. أرغب في أن يتم الترحيل إذا كانت قيمة الخلايا في العمود B لا تساوي صفر أو غير فارغة رابط هذا التعليق شارك More sharing options...
أفضل إجابة lionheart قام بنشر فبراير 28, 2022 أفضل إجابة مشاركة قام بنشر فبراير 28, 2022 Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, lc As Long, r As Long, c As Long, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) sh.Range("B7:C100").ClearContents lr = LastRow(ws) lc = LastCol(ws) m = 7 For r = 4 To lr Step 2 For c = 1 To lc If ws.Cells(r + 1, c).Value <> "" Then sh.Cells(m, 2).Value = ws.Cells(r, c).Value sh.Cells(m, 3).Value = ws.Cells(r + 1, c).Value m = m + 1 End If Next c Next r Application.ScreenUpdating = True MsgBox "Done", 64 End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row On Error GoTo 0 End Function Function LastCol(sh As Worksheet) On Error Resume Next LastCol = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column On Error GoTo 0 End Function 2 رابط هذا التعليق شارك More sharing options...
أبو عبد الله _ قام بنشر فبراير 28, 2022 الكاتب مشاركة قام بنشر فبراير 28, 2022 شكرا الاستاذ ( قبل الأسد ) تسلم يمينك هذا المطلوب بالفعل أرغب في اضافة بسيطة منكم 1- أن يتم العمل على الملف الرأسي لانني قمت بالتجهيز بالشكل الرأسي الموضح فى المرفق في المشاركة الثانية 2- أنه في حالة الضغط على ترحيل مرة ثانية ينقل البيانات تحت أخر صف يحتوى على بيانات رابط هذا التعليق شارك More sharing options...
الردود الموصى بها