bas harfi a-k arasında olanları 1. gruba l-z arasında olanları 2. grup atayacak makro kodu.

[gez.ze]

bir sınıf listesi verilmis bu sınıf listesinde bas harfi a-k harfleri arasında olanları butona bastığımızda öğrenci no ile 1. gruba l-z harfleri arasında olanları öğrenci numaraları ile 2. gruba atayacak makro programı isteniyor. Asağıya dosyayı bıraktım.
Simdiden tesekkür ederim.

makro4.xlsx dosyasını indir - download

makro4.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s7.dosya.tc

 

[Necdet]

Merhaba,
Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Public Sub Grup()

Dim arr As Variant, _
    ar1 As Variant, _
    ar2 As Variant, _
    a   As Long, _
    b   As Long, _
    i   As Long

Application.ScreenUpdating = False

Sayfa1.Range("F1").CurrentRegion.Offset(1).ClearContents
Sayfa1.Range("I1").CurrentRegion.Offset(1).ClearContents

i = Sayfa1.Cells(Rows.Count, "A").End(3).Row

arr = Range("A2:B" & i).Value
ReDim ar1(1 To UBound(arr, 1), 1 To 2)
ReDim ar2(1 To UBound(arr, 1), 1 To 2)

For i = LBound(arr, 1) To UBound(arr, 1)
    If Left(arr(i, 2), 1) < "K" Or _
       Left(arr(i, 2), 1) = "İ" Or _
       Left(arr(i, 2), 1) = "Ç" Then
        a = a + 1
        ar1(a, 1) = arr(i, 1)
        ar1(a, 2) = arr(i, 2)
    Else
        b = b + 1
        ar2(b, 1) = arr(i, 1)
        ar2(b, 2) = arr(i, 2)
    End If
Next i

Range("F2").Resize(UBound(arr, 1), UBound(arr, 2)) = ar1
Range("I2").Resize(UBound(arr, 1), UBound(arr, 2)) = ar2

Erase arr
Erase ar1
Erase ar2

Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır...."

End Sub

 

[Haluk]

Alternatif;

Sub Test()
'   Haluk - 03/01/2023

    MyFile = ThisWorkbook.FullName
    
    Set adoCN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
    RS.CursorType = 1 'adOpenKeyset
    
    adoCN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & MyFile & ";Extended Properties=Excel 8.0;"
    
    strSQL = "Select [ÖĞRENCİ NO], [ADI SOYADI] From [Sayfa1$] Where Left([ADI SOYADI],1) In ('A','B','C','Ç','D','E','F','G','H','I','İ','J','K')  "
    RS.Open strSQL, adoCN

    Range("F2").CopyFromRecordset RS
    RS.Close
    
    strSQL = "Select [ÖĞRENCİ NO], [ADI SOYADI] From [Sayfa1$] Where Left([ADI SOYADI],1) In ('L','M','N','O','Ö','P','R','S','Ş','T','U','Ü','V','Y','Z')  "
    RS.Open strSQL, adoCN
    
    Range("I2").CopyFromRecordset RS
    RS.Close
    
    Set RS = Nothing
    Set adoCN = Nothing
End Sub

.

 

[İdris SERDAR]

.

Bu da Table ve Pivot Table ile.

İndir pivotile

Dosyayı indir pivotile

dosya.co

.

 

[veyselemre]

Sub test()

    Dim strSQL$, strCon$, RS As Object

    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & ThisWorkbook.FullName & ";Excel 8.0;HDR=YES;IMEX=1"
    strSQL = "SELECT [ÖĞRENCİ NO], [ADI SOYADI] FROM [Sayfa1$] ORDER BY [ADI SOYADI]"

    Range("F2:J" & Rows.Count).ClearContents

    Set RS = CreateObject("ADODB.Recordset")
    RS.Open strSQL, strCon

    RS.Filter = "[ADI SOYADI]<'K'"
    Range("F2").CopyFromRecordset RS
    RS.Filter = "[ADI SOYADI]>'L'"
    Range("I2").CopyFromRecordset RS

    RS.Close

    Set RS = Nothing

End Sub

Sub test2()
    Dim i&, sat1&, sat2&
    Range("F2:J" & Rows.Count).ClearContents
    sat1 = 2
    sat2 = 2
    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        If StrComp(Cells(i, 2).Value, "L", vbTextCompare) = 1 Then
            Cells(sat1, "I").Resize(, 2).Value = Cells(i, 1).Resize(, 2).Value
            sat1 = sat1 + 1
        Else
            Cells(sat2, "F").Resize(, 2).Value = Cells(i, 1).Resize(, 2).Value
            sat2 = sat2 + 1
        End If
    Next i
End Sub

 

[gez.ze]

ilk atılan çalıstı çok tesekkür ederim ilginiz için.