Değişkenleri gruplandırma

[arda41]

Merhabalar,

Gruplandırma ile ilgili bir sorum var. Forumda gruplandırma konusu işlenmiş ancak maalesef mevcut çözümleri benim sorunuma uyarlayamadım. Ekteki excelde yapmaya çalıştığım işlemi açıklamaya çalıştım. Yardımcı olabilecek arkadaşlara şimdiden çok teşekkür ederim.

Saygılarımla

 

[caca85]

İsimlemeler sadece DKAL veya HKAL ile başlıyorsa bu kod işinizi görür.Farklı harflerle başlıyorsa kodu değiştirmek lazım.

Sub liste()

Columns(7).Delete
Columns(7).Delete


Columns(2).Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

For i = 2 To Range("A65536").End(3).Row
Cells(i, 2).Select
Selection.FormulaR1C1 = "=MID(RC[-1],1,4)"
Next i

For i2 = 2 To Range("B65536").End(3).Row
If Cells(i2, 2).Value = "DKAL" Then
Cells(Range("H65536").End(3).Row + 1, 8).Value = Cells(i2, 1).Value
ElseIf Cells(i2, 2).Value = "HKAL" Then
Cells(Range("I65536").End(3).Row + 1, 9).Value = Cells(i2, 1).Value
Else
End If
Next i2

Columns(2).Delete

Cells(1, 7).Value = "DKAL"
Cells(1, 7).Select
Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .ReadingOrder = xlContext
    End With
Cells(1, 8).Value = "HKAL"
Cells(1, 8).Select
Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .ReadingOrder = xlContext
    End With
End Sub

 

[caca85]

Önceki kod revize edilmiştir.

 

[systran]

Alternatif olsun.

Sub gruplandır()
Dim ptrD, ptrH, satir, i As Integer
Dim tmpStr As String * 4
Dim tmpStrFull As String
ptrD = 1
ptrH = 1
satir = Sayfa1.Range("A1048576").End(xlUp).Row
Sayfa1.Range("G:H").Clearcontents
For i = 2 To satir
    tmpStrFull = Sayfa1.Cells(i, 1) '1 nolu sütun A
    tmpStr = tmpStrFull
    If tmpStr = "DKAL" Then
        Sayfa1.Cells(ptrD, 7) = tmpStrFull  '7 nolu sütun G
        ptrD = ptrD + 1
    ElseIf tmpStr = "HKAL" Then
        Sayfa1.Cells(ptrH, 8) = tmpStrFull  '8 nolu sütun H
        ptrH = ptrH + 1
    End If
Next i

End Sub

 

[arda41]

Sayın Systran,

Çok teşekkür ederim. Ellerinize sağlık. Problemim çözülmüştür.

Saygılarımla