Excel VBA .Net

Kod: Tümünü seç


Private Sub CommandButton1_Click()

Dim syf As Worksheet
i = 8
    For Each syf In Worksheets
       
       
If Left(syf.Name, 3) = "GRP" Then
Cells(i, 3).Value = syf.Name

    i = i + 1
    End If
    Next syf

End Sub


okutkan yazdı:

Kod: Tümünü seç


Private Sub CommandButton1_Click()

Dim syf As Worksheet
i = 8
    For Each syf In Worksheets
       
       
If Left(syf.Name, 3) = "GRP" Then
Cells(i, 3).Value = syf.Name

    i = i + 1
    End If
    Next syf

End Sub


Kod: Tümünü seç

Private Sub CommandButton1_Click()

Dim syf As Worksheet
i = 8
j = 8
k = 8
l = 8
m = 8

    For Each syf In Worksheets
       
       
If Left(syf.Name, 5) = "GRP-1" Then
Cells(i, 3).Value = syf.Name
    i = i + 1
    End If
   
If Left(syf.Name, 5) = "GRP-2" Then
Cells(j, 4).Value = syf.Name
    j = j + 1
    End If
   
If Left(syf.Name, 5) = "GRP-3" Then
Cells(k, 5).Value = syf.Name
    k = k + 1
    End If

If Left(syf.Name, 5) = "GRP-4" Then
Cells(l, 6).Value = syf.Name
    l = l + 1
    End If
   
If Left(syf.Name, 5) = "GRP-5" Then
Cells(m, 7).Value = syf.Name
    m = m + 1
    End If
    Next syf

End Sub



düşünceli yazdı:Aynı anda cevap yazmışız. Ama yine aynı değişen bir şey yok. Grp-1.... bila grp-5 hangi grup ismiyle başlıyorsa grup ismiyle gösterdiğim sütuna ayrıştırsın..

Örneğin:
Grp-1 "C" sütunu altına... bila Grp-5 "G" sütunu altına gelecek şekilde.

Kod: Tümünü seç

Dim syf As Worksheet
i = 8
For Each syf In Worksheets
If Left(syf.Name, 5) = "GRP-1" Then
Cells(i, 3).Value = syf.Name
    i = i + 1
    End If
    Next syf
i = 8
For Each syf In Worksheets
If Left(syf.Name, 5) = "GRP-2" Then
Cells(i, 4).Value = syf.Name
    i = i + 1
    End If
    Next syf
i = 8
For Each syf In Worksheets
If Left(syf.Name, 5) = "GRP-3" Then
Cells(i, 5).Value = syf.Name
    i = i + 1
    End If
    Next syf
i = 8
For Each syf In Worksheets
  If Left(syf.Name, 5) = "GRP-4" Then
Cells(i, 6).Value = syf.Name
    i = i + 1
    End If
    Next syf
i = 8
For Each syf In Worksheets
   If Left(syf.Name, 5) = "GRP-5" Then
Cells(i, 7).Value = syf.Name
    i = i + 1
    End If
    Next syf
End Sub

okutkan yazdı:Malesef o konuda bilgim yok.

halily yazdı:Grp-1....Grp-5 formatında 5 grup tek mi olacak?
sıralama da yıllara göre küçükten büyüğe mi olacak?

düşünceli yazdı:

halily yazdı:Grp-1....Grp-5 formatında 5 grup tek mi olacak?
sıralama da yıllara göre küçükten büyüğe mi olacak?

Evet dediğiniz gibi olur. Gruplara ayırarak 1 den 12 ye kadar sıralasın yeterli.

GRP-1-2021-1 GRP-2-2021-1
GRP-1-2021-2 GRP-2-2021-2
. .
. .
. .
GRP-1-2021-12 GRP-2-2021-12

Kod: Tümünü seç

Function SiralaDict()
   
    Dim syf As Worksheet '
    Dim syfHdf As Worksheet
    Dim kriter
    Dim dict As Scripting.Dictionary
   
    Set dict = New Scripting.Dictionary
    Set syfHdf = Worksheets("SilHy")
    '________________________
    syfHdf.Cells.ClearContents
    For Each syf In Worksheets
   
    If Left(syf.Name, 3) = "GRP" Then
    kriter = Left(syf.Name, 5)
               If Not dict.Exists(kriter) Then
                  dict.Add kriter, syf.Name
                                 
                Else
                    dict(kriter) = dict.Item(kriter) & "|" & syf.Name
                End If
     End If
     Next syf

With syfHdf
For xKey = 1 To dict.Count
kriter = "GRP-" & xKey
zTxt = dict.Item(kriter)
    If Len(zTxt & "") > 0 Then
    Dim xArr() As String
        xArr = Split(zTxt, "|")
        .Cells(7, xKey + 2) = kriter
        For xStr = LBound(xArr) To UBound(xArr)
            .Cells(8 + xStr, xKey + 2) = xArr(xStr) 'SonDizi
        Next xStr
    End If
Next xKey
End With


var:
    Set dict = Nothing
End Function


halily yazdı:aşağıdaki kodu dener misiniz?
Not: Referanslardan Microsoft Scripting Runtime eklenmeli

Kod: Tümünü seç

Function SiralaDict()
   
    Dim syf As Worksheet '
    Dim syfHdf As Worksheet
    Dim kriter
    Dim dict As Scripting.Dictionary
   
    Set dict = New Scripting.Dictionary
    Set syfHdf = Worksheets("SilHy")
    '________________________
    syfHdf.Cells.ClearContents
    For Each syf In Worksheets
   
    If Left(syf.Name, 3) = "GRP" Then
    kriter = Left(syf.Name, 5)
               If Not dict.Exists(kriter) Then
                  dict.Add kriter, syf.Name
                                 
                Else
                    dict(kriter) = dict.Item(kriter) & "|" & syf.Name
                End If
     End If
     Next syf

With syfHdf
For xKey = 1 To dict.Count
kriter = "GRP-" & xKey
zTxt = dict.Item(kriter)
    If Len(zTxt & "") > 0 Then
    Dim xArr() As String
        xArr = Split(zTxt, "|")
        .Cells(7, xKey + 2) = kriter
        For xStr = LBound(xArr) To UBound(xArr)
            .Cells(8 + xStr, xKey + 2) = xArr(xStr) 'SonDizi
        Next xStr
    End If
Next xKey
End With


var:
    Set dict = Nothing
End Function


Kod: Tümünü seç

    Set syfHdf = ThisWorkbook.ActiveSheet

halily yazdı:maalesef sadece hangi sayfaya yazılacaksa o sayfanın Worksheet_Activate() olayına yazılacak
aslında herhangi bir sayfanın Worksheet_Activate() olayına çalışması için
Set syfHdf = Worksheets("SilHy") satırı aşağıdaki satırla değiştirilmeli

Kod: Tümünü seç

    Set syfHdf = ThisWorkbook.ActiveSheet

Kod: Tümünü seç

Private Sub Worksheet_Activate()
SiralaDict
End Sub

halily yazdı:bir önceki mesajımda belirttiğim gibi
bu kod Worksheet_Activate olayında çalışır; yani hücre içine yazınca çalışan bir kod değil
mesela verilerin yazılmasını istediğiniz sayfa Veri adlı bir sayfa olsun siz her bu sayfaya geldiğinizde bu kod çalışıp sayfayı günceller. aşağıdaki kod VERI sayfasının Worksheet_Activate olayına ait

Kod: Tümünü seç

Private Sub Worksheet_Activate()
SiralaDict
End Sub

Kod: Tümünü seç

Function Grupla(alan As Range) As Variant()
Application.Volatile
Set liste = CreateObject("System.Collections.ArrayList")
For Each sayfa In Worksheets
   If Left(sayfa.Name, 3) = "GRP" Then
      liste.Add sayfa.Name
   End If
Next
liste.Sort
dizim = Filter(liste.toarray, alan.Value)
Dim dizi(12, 0)
For i = LBound(dizim) To UBound(dizim)
dizi(i, 0) = dizim(i)
Next
Grupla = dizi
End Function

Erkan Akayay yazdı:KTF ile şöyle bir çözüm yaptım. Dizi formülüdür. C8:C19 arasını seçip Formülü yazın. CTRL+SHIFT+ENTER tuşlarına basın. Sonra sağa doğru sürükleyip kopyalayabilirsiniz.

Kod: Tümünü seç

Function Grupla(alan As Range) As Variant()
Application.Volatile
Set liste = CreateObject("System.Collections.ArrayList")
For Each sayfa In Worksheets
   If Left(sayfa.Name, 3) = "GRP" Then
      liste.Add sayfa.Name
   End If
Next
liste.Sort
dizim = Filter(liste.toarray, alan.Value)
Dim dizi(12, 0)
For i = LBound(dizim) To UBound(dizim)
dizi(i, 0) = dizim(i)
Next
Grupla = dizi
End Function