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

يونيو 24, 2023

**lionheart** · يونيو 24, 2023

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

أبوأحـمـد · يونيو 24, 2023

وهنا بالمعادلات

خالد.xlsb

يونيو 24, 2023

منذ ساعه, أبوأحـمـد 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** · يونيو 24, 2023

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

يونيو 24, 2023

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

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

**lionheart** · يونيو 24, 2023

this line will store any row that doesn't have the text

 .....If sh.Cells(r, "AN").Value <> Join(Array(C

يونيو 24, 2023

Chr(207), Chr(230), Chr(209), Chr(32), Chr(203), Chr(199), Chr(228), Chr(237)

وده معناه ايه

يونيو 24, 2023

=IFERROR(INDEX(شيت!$A$7:$A$48;AGGREGATE(15;6;(ROW($A$1:$A$100)/(شيت!$AN$7:$AN$48="دور ثاني"));ROW(A1));1);"")

ممكن شرحها في الملف

**محمد هشام.** · يونيو 25, 2023

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

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

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

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

يونيو 25, 2023

انا علمت تغيير في الورقة والكود مش شغال Mohamed Hicham

V1 خالد.xlsb

**محمد هشام.** · يونيو 25, 2023

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

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

يونيو 26, 2023

في 24‏/6‏/2023 at 17:10, أبوأحـمـد said:

وهنا بالمعادلات

AGGREGATE(15;6;(

رقم 16 خاص بايه ورقم 5 خاص بايه

تسجيل الدخول

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

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

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

lionheart

أبوأحـمـد

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

lionheart

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

lionheart

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

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

محمد هشام.

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

محمد هشام.

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

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information