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

عمل كود تلقائي او معادلة لنقل الراسبين لورقة خاصة بيهم

خالد المصـــــــــــرى
 مشاركة
إذهب إلى أفضل إجابة Solved by أبوأحـمـد,

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

lionheart

lionheart

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

Try this code. Copy the headers manually first. The code will put the results at row 7 as start point 

Sub Test()
    Const SROW As Long = 7
    Dim ws As Worksheet, sh As Worksheet, rng As Range, lr As Long, r As Long
    Application.ScreenUpdating = False
        With ThisWorkbook
            Set ws = .Worksheets(1): Set sh = .Worksheets(2)
        End With
        sh.Rows(SROW & ":" & Rows.Count).Cells.Clear
        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
        If lr < SROW Then Exit Sub
        ws.Range("A" & SROW & ":G" & lr).Copy sh.Range("A" & SROW)
        ws.Range("AN" & SROW & ":AN" & lr).Copy sh.Range("AN" & SROW)
        For r = SROW To lr
            If sh.Cells(r, "AN").Value <> Join(Array(Chr(207), Chr(230), Chr(209), Chr(32), Chr(203), Chr(199), Chr(228), Chr(237)), Empty) Then
                If rng Is Nothing Then Set rng = sh.Rows(r) Else Set rng = Union(rng, sh.Rows(r))
            End If
        Next r
        If Not rng Is Nothing Then rng.EntireRow.Delete
        lr = sh.Cells(Rows.Count, "C").End(xlUp).Row
        If lr < SROW Then Exit Sub
        sh.Range("A" & SROW).Resize(lr - SROW + 1).Value = Evaluate("ROW(1:" & lr - SROW + 1 & ")")
    Application.ScreenUpdating = True
End Sub

 

  • Like 4
رابط هذا التعليق
شارك
خالد المصـــــــــــرى

خالد المصـــــــــــرى

قام بنشر
  • الكاتب
قام بنشر
منذ ساعه, أبوأحـمـد said:

lممكن شرح الكود 

Sub Test()
    Const SROW As Long = 7
    Dim ws As Worksheet, sh As Worksheet, rng As Range, lr As Long, r As Long
    Application.ScreenUpdating = False
        With ThisWorkbook
            Set ws = .Worksheets(1): Set sh = .Worksheets(2)
        End With
        sh.Rows(SROW & ":" & Rows.Count).Cells.Clear
        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
        If lr < SROW Then Exit Sub
        ws.Range("A" & SROW & ":G" & lr).Copy sh.Range("A" & SROW)
        ws.Range("AN" & SROW & ":AN" & lr).Copy sh.Range("AN" & SROW)
        For r = SROW To lr
            If sh.Cells(r, "AN").Value <> Join(Array(Chr(207), Chr(230), Chr(209), Chr(32), Chr(203), Chr(199), Chr(228), Chr(237)), Empty) Then
                If rng Is Nothing Then Set rng = sh.Rows(r) Else Set rng = Union(rng, sh.Rows(r))
            End If
        Next r
        If Not rng Is Nothing Then rng.EntireRow.Delete
        lr = sh.Cells(Rows.Count, "C").End(xlUp).Row
        If lr < SROW Then Exit Sub
        sh.Range("A" & SROW).Resize(lr - SROW + 1).Value = Evaluate("ROW(1:" & lr - SROW + 1 & ")")
    Application.ScreenUpdating = True
End Sub
رابط هذا التعليق
شارك
lionheart

lionheart

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

Hope this help you 

Sub Test()
    Const SROW As Long = 7  ' Start row constant, set to row 7
    Dim ws As Worksheet, sh As Worksheet, rng As Range, lr As Long, r As Long
    Application.ScreenUpdating = False  ' Disable screen updating to improve performance
    With ThisWorkbook
        Set ws = .Worksheets(1): Set sh = .Worksheets(2)  ' Set variables ws and sh to the first and second worksheets in the workbook, respectively
    End With
    sh.Rows(SROW & ":" & Rows.Count).Cells.Clear  ' Clear all cells in rows from SROW to the last row in worksheet sh
    lr = ws.Cells(Rows.Count, "C").End(xlUp).Row  ' Find the last used row in column C of worksheet ws
    If lr < SROW Then Exit Sub  ' If the last used row is less than the start row, exit the subroutine
    ws.Range("A" & SROW & ":G" & lr).Copy sh.Range("A" & SROW)  ' Copy the range from column A to G, starting from SROW to lr, from worksheet ws to worksheet sh
    ws.Range("AN" & SROW & ":AN" & lr).Copy sh.Range("AN" & SROW)  ' Copy the range in column AN, starting from SROW to lr, from worksheet ws to worksheet sh
    For r = SROW To lr  ' Loop through each row from SROW to lr
        If sh.Cells(r, "AN").Value <> Join(Array(Chr(207), Chr(230), Chr(209), Chr(32), Chr(203), Chr(199), Chr(228), Chr(237)), Empty) Then
            ' Check if the value in column AN of the current row in worksheet sh is not equal to the joined characters
            If rng Is Nothing Then Set rng = sh.Rows(r) Else Set rng = Union(rng, sh.Rows(r))  ' If rng is Nothing, set rng to the current row, otherwise, combine rng with the current row using the Union function
        End If
    Next r
    If Not rng Is Nothing Then rng.EntireRow.Delete  ' If rng is not Nothing (i.e., there are rows to be deleted), delete the entire rows of rng
    lr = sh.Cells(Rows.Count, "C").End(xlUp).Row  ' Find the last used row in column C of worksheet sh
    If lr < SROW Then Exit Sub  ' If the last used row is less than the start row, exit the subroutine
    sh.Range("A" & SROW).Resize(lr - SROW + 1).Value = Evaluate("ROW(1:" & lr - SROW + 1 & ")")  ' Populate the range starting from cell A7 to the last used row in column C of worksheet sh with the row numbers using the Evaluate function
    Application.ScreenUpdating = True  ' Enable screen updating
End Sub

 

  • Like 1
رابط هذا التعليق
شارك
خالد المصـــــــــــرى

خالد المصـــــــــــرى

قام بنشر
  • الكاتب
قام بنشر
3 ساعات مضت, lionheart said:

  

Sub Test()
    Const SROW As Long = 7  ' Start row constant, set to row 7
    Dim ws As Worksheet, sh As Worksheet, rng As Range, lr As Long, r As Long
    Application.ScreenUpdating = False  ' Disable screen updating to improve performance
    With ThisWorkbook
        Set ws = .Worksheets(1): Set sh = .Worksheets(2)  ' Set variables ws and sh to the first and second worksheets in the workbook, respectively
    End With
    sh.Rows(SROW & ":" & Rows.Count).Cells.Clear  ' Clear all cells in rows from SROW to the last row in worksheet sh
    lr = ws.Cells(Rows.Count, "C").End(xlUp).Row  ' Find the last used row in column C of worksheet ws
    If lr < SROW Then Exit Sub  ' If the last used row is less than the start row, exit the subroutine
    ws.Range("A" & SROW & ":G" & lr).Copy sh.Range("A" & SROW)  ' Copy the range from column A to G, starting from SROW to lr, from worksheet ws to worksheet sh
    ws.Range("AN" & SROW & ":AN" & lr).Copy sh.Range("AN" & SROW)  ' Copy the range in column AN, starting from SROW to lr, from worksheet ws to worksheet sh
    For r = SROW To lr  ' Loop through each row from SROW to lr
        If sh.Cells(r, "AN").Value <> Join(Array(Chr(207), Chr(230), Chr(209), Chr(32), Chr(203), Chr(199), Chr(228), Chr(237)), Empty) Then
            ' Check if the value in column AN of the current row in worksheet sh is not equal to the joined characters
            If rng Is Nothing Then Set rng = sh.Rows(r) Else Set rng = Union(rng, sh.Rows(r))  ' If rng is Nothing, set rng to the current row, otherwise, combine rng with the current row using the Union function
        End If
    Next r
    If Not rng Is Nothing Then rng.EntireRow.Delete  ' If rng is not Nothing (i.e., there are rows to be deleted), delete the entire rows of rng
    lr = sh.Cells(Rows.Count, "C").End(xlUp).Row  ' Find the last used row in column C of worksheet sh
    If lr < SROW Then Exit Sub  ' If the last used row is less than the start row, exit the subroutine
    sh.Range("A" & SROW).Resize(lr - SROW + 1).Value = Evaluate("ROW(1:" & lr - SROW + 1 & ")")  ' Populate the range starting from cell A7 to the last used row in column C of worksheet sh with the row numbers using the Evaluate function
    Application.ScreenUpdating = True  ' Enable screen updating
End Sub

فين شرط دور ثاني في الكود

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

محمد هشام.

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

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

بعد ادن الاخوة الكرام اليك اخي حل اخر

استدعاء الراسبين الى ورقة دور ثاني في حالة الوجود  المسبق لرؤوس عناوين الاعمدة  

Sub CopyData1()
Dim x, y(), i&, lr&, a&, r&

Set sh1 = ThisWorkbook.Worksheets("شيت")
Set sh2 = ThisWorkbook.Worksheets("دور ثان")

lr = sh1.Range("a" & Rows.Count).End(xlUp).Row
lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row

Application.ScreenUpdating = False
 x = sh1.Range("A7:AN" & lr)
 For i = 1 To UBound(x, 1)
 If x(i, 40) = "دور ثاني" Then
 r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r)
 For a = 1 To UBound(x, 2)
 y(a, r) = x(i, a)
 Next
 End If
 Next
 With sh2
 sh2.Range("A7:AN" & lr2).ClearContents
 sh2.[A7].Resize(r, UBound(y, 1)) = Application.Transpose(y)
 F = sh2.Range("A65500").End(xlUp).Row
 G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column
      sh2.Range("A7:AN" & lr2).Borders.LineStyle = xlNone
sh2.Range(Cells(7, 1), sh2.Cells(F, G)).Borders.Weight = xlThin
 End With
 Application.ScreenUpdating = True
End Sub

 ولنسخ البيانات الى ورقة لا تتضمن رؤوس اعمدة يمكنك استخدام الكود التالي 

  

Sub CopyData2()
Dim rAlt As Range
Dim x, y(), i&, lr&, a&, r&, n&

Set sh1 = ThisWorkbook.Worksheets("شيت")
Set sh2 = ThisWorkbook.Worksheets("Sheet3")
lr = sh1.Range("a" & Rows.Count).End(xlUp).Row
lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row

Application.ScreenUpdating = False
  Set rAlt = sh1.Range("A1:AN6")
  For n = 1 To 40
    Set rAlt = Union(rAlt, Intersect(rAlt.EntireRow, Columns(n)))
  Next n
 
  rAlt.COPY Destination:=sh2.Range("A1")
 
 x = sh1.Range("A7:AN" & lr)
     For i = 1 To UBound(x, 1)
 If x(i, 40) = "دور ثاني" Then
   r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r)
 For a = 1 To UBound(x, 2)
   y(a, r) = x(i, a)
      Next
   End If
 Next
 
 sh2.Activate
 [A7].Resize(r, UBound(y, 1)) = Application.Transpose(y)
 F = sh2.Range("A65500").End(xlUp).Row
 G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column
          Range("A7:an100").Borders.LineStyle = xlNone
Range(Cells(7, 1), Cells(F, G)).Borders.Weight = xlThin
Columns("A:AN").EntireColumn.AutoFit
Columns("H:AM").EntireColumn.Hidden = True
 
 Application.ScreenUpdating = True
  
End Sub

 

V1 خالد.xlsb

  • Like 3
رابط هذا التعليق
شارك
محمد هشام.

محمد هشام.

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

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

Sub CopyData()
Dim x, y(), i&, lr&, a&, r&

Set sh1 = ThisWorkbook.Worksheets("شيت")
Set sh2 = ThisWorkbook.Worksheets("دور ثان")

lr = sh1.Range("a" & Rows.Count).End(xlUp).Row
lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row

Application.ScreenUpdating = False
' نطاق البيانات
 x = sh1.Range("A7:H" & lr)
 For i = 1 To UBound(x, 1)
 'H' الشرط في العمود
 If x(i, 8) = "دور ثاني" Then
 r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r)
 For a = 1 To UBound(x, 2)
 y(a, r) = x(i, a)
 Next
 End If
 Next
 With sh2
 ' افراغ البيانات السابقة
 sh2.Range("A7:H" & lr2).ClearContents
 ' لصق البيانات
 sh2.[A7].Resize(r, UBound(y, 1)) = Application.Transpose(y)
 'تسطير الجدول
 F = sh2.Range("A65500").End(xlUp).Row
 G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column
      sh2.Range("A7:H" & lr2).Borders.LineStyle = xlNone
sh2.Range(Cells(7, 1), sh2.Cells(F, G)).Borders.Weight = xlThin
 End With
 Application.ScreenUpdating = True
End Sub

ولنسخ البيانات الى ورقة لا تتضمن رؤوس اعمدة هدا مثال لاستدعاء الناجحين 

Sub CopyData2()
Dim rAlt As Range
Dim x, y(), i&, lr&, a&, r&, n&

Set sh1 = ThisWorkbook.Worksheets("شيت")
Set sh2 = ThisWorkbook.Worksheets("ناجح")
lr = sh1.Range("a" & Rows.Count).End(xlUp).Row
lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row
Application.ScreenUpdating = False
sh1.Activate

'نسخ رؤؤوس الاعمدة
  Set rAlt = sh1.Range("A1:H6")
  For n = 1 To 8
    Set rAlt = Union(rAlt, Intersect(rAlt.EntireRow, Columns(n)))
  Next n
 'لصق
  rAlt.COPY Destination:=sh2.Range("A1")
 
 x = sh1.Range("A7:H" & lr)
     For i = 1 To UBound(x, 1)
     ' المعيار
 If x(i, 8) = "ناجح" Then

   r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r)
 For a = 1 To UBound(x, 2)
   y(a, r) = x(i, a)
      Next
   End If
 Next
 
 sh2.Activate
 'لصق في الصف السابع
 [A7].Resize(r, UBound(y, 1)) = Application.Transpose(y)
 ' تسطير حدود البيانات
 F = sh2.Range("A65500").End(xlUp).Row
 G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column
          Range("A7:H1000").Borders.LineStyle = xlNone
Range(Cells(7, 1), Cells(F, G)).Borders.Weight = xlThin
' تنسيق الاعمدة
Columns("A:H").EntireColumn.AutoFit
 Application.ScreenUpdating = True
     
End Sub

 

v2 خالد.xlsb

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept