Dikey tabloyu yataya çevirme ve dizi oluşturma..

tamer42

Destek Ekibi
Destek Ekibi
Katılım
11 Mart 2005
Mesajlar
3,059
Excel Vers. ve Dili
Office 2013 İngilizce
Merhaba,
Ekli tabloda il ve bağlı ilçe bilgileri mevcut,

Öncelikle Buradaki ilçe bilgileri "Yatay-Dizi" sayfasında göründüğü gibi; ilçeler sayfasındaki bilgileri iki boyutlu (dikey:81, yatay: 40 gibi..) bir diziye aktarmak istiyorum.
devamında ise dizi içinde bazı işlemler yapacağım.
Dizide boş olan ilçe bilgileri boş gelsin çok önemli değil, önemli olan dolu olanların doğru gelmesi

Dizi(1,1) = "Seyhan"
Dizi(2,3) = "Çelikhan"
Dizi(2,12) =""
.....
..........
...............
gibi..

Dizide boş olan ilçe bilgileri boş gelsin çok önemli değil, önemli olan dolu olanların doğru gelmesi,

işin açıkçası for .... next ve if .... End if ile uzun-uzun kod yazarak yapılabilir ama; ben daha pratik bir çözüm arayışı içindeyim

ilgi ve alakanız için şimdiden teşekkürler

iyi çalışmalar.
 

Ekli dosyalar

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
C++:
Sub ililce()
    Dim i As Integer, Maxilce As Integer, Liste()
    Arr1 = Worksheets("Iller").Range("A1").CurrentRegion.Value
    Arr2 = Worksheets("Ilceler").Range("A1").CurrentRegion.Value
    ReDim Liste(1 To UBound(Arr1), 1 To Columns.Count)
    For i = 1 To UBound(Arr1)
        Liste(i, 1) = i
        Liste(i, 2) = Arr1(i, 2)
        Liste(i, Columns.Count) = 3
        Maxilce = WorksheetFunction.Max(Maxilce, Arr1(i, 3))
    Next i
    For i = 1 To UBound(Arr2)
        Liste(Arr2(i, 3), Liste(Arr2(i, 3), Columns.Count)) = Arr2(i, 2)
        Liste(Arr2(i, 3), Columns.Count) = Liste(Arr2(i, 3), Columns.Count) + 1
    Next i
    Worksheets("Yatay-Dizi").Cells.ClearContents
    Worksheets("Yatay-Dizi").Range("A2").Resize(UBound(Liste), Maxilce + 2) = Liste
    For i = 1 To Maxilce
        Worksheets("Yatay-Dizi").Range("A1").Offset(0, i + 1) = i
    Next i
End Sub
 

tamer42

Destek Ekibi
Destek Ekibi
Katılım
11 Mart 2005
Mesajlar
3,059
Excel Vers. ve Dili
Office 2013 İngilizce
C++:
Sub ililce()
    Dim i As Integer, Maxilce As Integer, Liste()
    Arr1 = Worksheets("Iller").Range("A1").CurrentRegion.Value
    Arr2 = Worksheets("Ilceler").Range("A1").CurrentRegion.Value
    ReDim Liste(1 To UBound(Arr1), 1 To Columns.Count)
    For i = 1 To UBound(Arr1)
        Liste(i, 1) = i
        Liste(i, 2) = Arr1(i, 2)
        Liste(i, Columns.Count) = 3
        Maxilce = WorksheetFunction.Max(Maxilce, Arr1(i, 3))
    Next i
    For i = 1 To UBound(Arr2)
        Liste(Arr2(i, 3), Liste(Arr2(i, 3), Columns.Count)) = Arr2(i, 2)
        Liste(Arr2(i, 3), Columns.Count) = Liste(Arr2(i, 3), Columns.Count) + 1
    Next i
    Worksheets("Yatay-Dizi").Cells.ClearContents
    Worksheets("Yatay-Dizi").Range("A2").Resize(UBound(Liste), Maxilce + 2) = Liste
    For i = 1 To Maxilce
        Worksheets("Yatay-Dizi").Range("A1").Offset(0, i + 1) = i
    Next i
End Sub
Çok Teşekkürler Ömer Faruk Hocam...
Ekli dosyadaki sadece ilçe sayfasının olduğu bir format olursa (Sadece İl Kodu ve İlçe Adları) kodları nasıl düzenleyebiliriz?

tekrar teşekkürler.
 

Ekli dosyalar

Son düzenleme:

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,105
Excel Vers. ve Dili
office2010
Ekli dosyadaki sadece ilçe sayfasının olduğu bir format olursa (Sadece İl Kodu ve İlçe Adları) kodları nasıl düzenleyebiliriz?

Kod:
Option Explicit
Private Sub CommandButton1_Click()
Dim a(), b(), dc As Object, ds As Object, _
    s1 As Worksheet, s2 As Worksheet, _
    i As Long, j As Byte, sat As Long, sut As Byte, _
    il(), ilce(), deg, krt As String

Set s1 = Sheets("Ilceler")
Set s2 = Sheets("Yatay-Dizi")


Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")

a = s1.Range("A1:B" & s1.Cells(Rows.Count, 1).End(3).Row).Value

For i = 1 To UBound(a)
    krt = CStr(a(i, 1))
    dc(krt) = dc(krt) & "|" & a(i, 2)
    ds(krt) = ds(krt) + 1
Next i

il = dc.keys: ilce = dc.items
sat = dc.Count: sut = Application.Max(ds.items)

ReDim b(1 To sat, 1 To sut + 5)

For i = 1 To sat
    b(i, 1) = il(i - 1)
    deg = Split(ilce(i - 1), "|")
    For j = 2 To UBound(deg)
        b(i, j) = deg(j)
    Next j
Next i

s2.Cells.ClearContents
s2.Cells.ClearFormats
s2.[A2].Resize(sat, sut) = b
s2.[A2].Resize(sat, sut).EntireColumn.AutoFit
s2.[A2].Resize(sat, sut).Borders.Color = rgbSilver
s2.[A2].Resize(sat, sut).BorderAround , xlThin
s2.[A2].Resize(sat).BorderAround , xlThin
MsgBox "İşlem tamam.", vbInformation
End Sub
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,

Alternatif olsun. Dizileri , ScriptinDictionary i bilmeyenler için sadece VBA kullanarak

Kod:
Sub Yatay()

    Dim i   As Long, _
        j   As Integer, _
        eRow As Long, _
        eski As String
    
    With Application
        .ScreenUpdating = False
    End With
    
    Sayfa3.Cells.ClearContents
    eRow = 1
    eski = Sayfa2.Cells(1, 1)
    
    j = 1
    For i = 1 To Sayfa2.Cells(Rows.Count, "A").End(3).Row + 1
        If Sayfa2.Cells(i, "A") <> eski Then
            j = j + 1
            Sayfa3.Cells(j, "A") = eski
            Sayfa2.Range("B" & eRow & ":B" & i - 1).Copy
            Sayfa3.Range("B" & j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                                    False, Transpose:=True
        eRow = i
        eski = Sayfa2.Cells(i, "A")

        End If
    Next i
    
    With Application
        .ScreenUpdating = True
        .CutCopyMode = True
    End With
    
End Sub
 

tamer42

Destek Ekibi
Destek Ekibi
Katılım
11 Mart 2005
Mesajlar
3,059
Excel Vers. ve Dili
Office 2013 İngilizce
Kod:
Option Explicit
Private Sub CommandButton1_Click()
...............
End Sub
Ziynettin, Necdet ve Ömer Faruk hocalarım ilgi ve alakalarınız için teşekkürler.
tam istediğim gibi oldu aslında,
işin doğrusu bu işlemin bir adım öncesinde İlçe sayfasındaki bilgileri kapalı bir dosyadan çekip, bu şekliyle bir dizi içerisine aktarmıştım, ben diziden doğrudan işlem yaparken zorlanırım diye sayfaya aktarıyor, sonra sayfadan devam ederim diye düşünmüştüm.

İlçe sayfasına kopyalama yapmadan, yani sayfaya aktarmadan bu işlemi doğrudan dizi içerisinden nasıl yazabiliriz?
Özetle: tmpArrray2 = Worksheets("Ilceler").Range("A1").CurrentRegion.Value

gibi düşüneceğiz.

Kod:
Con.Open strConnection
Set RS = Con.Execute(Sorgu)
tmpArrray = RS.GetRows
'''''
tmpArrray2 = Application.transpose(tmpArrray)
iyi günler, iyi çalışmalar.
 

tamer42

Destek Ekibi
Destek Ekibi
Katılım
11 Mart 2005
Mesajlar
3,059
Excel Vers. ve Dili
Office 2013 İngilizce
Ziynettin, Necdet ve Ömer Faruk hocalarım ilgi ve alakalarınız için teşekkürler.
tam istediğim gibi oldu aslında,
işin doğrusu bu işlemin bir adım öncesinde İlçe sayfasındaki bilgileri kapalı bir dosyadan çekip, bu şekliyle bir dizi içerisine aktarmıştım, ben diziden doğrudan işlem yaparken zorlanırım diye sayfaya aktarıyor, sonra sayfadan devam ederim diye düşünmüştüm.

İlçe sayfasına kopyalama yapmadan, yani sayfaya aktarmadan bu işlemi doğrudan dizi içerisinden nasıl yazabiliriz?
Özetle: tmpArrray2 = Worksheets("Ilceler").Range("A1").CurrentRegion.Value

gibi düşüneceğiz.

Kod:
Con.Open strConnection
Set RS = Con.Execute(Sorgu)
tmpArrray = RS.GetRows
'''''
tmpArrray2 = Application.transpose(tmpArrray)
iyi günler, iyi çalışmalar.
Aşağıdakş şekide çözüldü, her şey için tekrar tekrar teşekkürler

Kod:
'''a = s1.Range("A1:B" & s1.Cells(Rows.Count, 1).End(3).Row).Value
a=tmpArrray2
 

tamer42

Destek Ekibi
Destek Ekibi
Katılım
11 Mart 2005
Mesajlar
3,059
Excel Vers. ve Dili
Office 2013 İngilizce
Kod:
Option Explicit
Private Sub CommandButton1_Click()
Dim a(), b(), dc As Object, ds As Object, _
    s1 As Worksheet, s2 As Worksheet, _
    i As Long, j As Byte, sat As Long, sut As Byte, _
    il(), ilce(), deg, krt As String

Set s1 = Sheets("Ilceler")
Set s2 = Sheets("Yatay-Dizi")


Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")

a = s1.Range("A1:B" & s1.Cells(Rows.Count, 1).End(3).Row).Value

For i = 1 To UBound(a)
    krt = CStr(a(i, 1))
    dc(krt) = dc(krt) & "|" & a(i, 2)
    ds(krt) = ds(krt) + 1
Next i

il = dc.keys: ilce = dc.items
sat = dc.Count: sut = Application.Max(ds.items)

ReDim b(1 To sat, 1 To sut + 5)

For i = 1 To sat
    b(i, 1) = il(i - 1)
    deg = Split(ilce(i - 1), "|")
    For j = 2 To UBound(deg)
        b(i, j) = deg(j)
    Next j
Next i

s2.Cells.ClearContents
s2.Cells.ClearFormats
s2.[A2].Resize(sat, sut) = b
s2.[A2].Resize(sat, sut).EntireColumn.AutoFit
s2.[A2].Resize(sat, sut).Borders.Color = rgbSilver
s2.[A2].Resize(sat, sut).BorderAround , xlThin
s2.[A2].Resize(sat).BorderAround , xlThin
MsgBox "İşlem tamam.", vbInformation
End Sub
Ziynettin Hocam kusura bakmayın , yeni bir durum fark ettim, her il için ilk sıradaki ilçe bilgileri gelmiyor.
ekli dosyada görebilirsiniz,
Örnek: Adana Ceyhan' dan başlıyor, oysa Seyhan' dan başlamalı..

iyi çalışmalar.
 

Ekli dosyalar

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,
Ben de sadece diziyle çalışan bir alternatif önereyim.

Dener misiniz?

Kod:
Sub DizilerleCalisma()

    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim e As Integer
    Dim Arr As Variant
    Dim diz As Variant
    Dim t
    t = Time
    
    Application.ScreenUpdating = False
    
    Sayfa3.Range("A1") = "İl"
    Sayfa3.Range("A1").CurrentRegion.Offset(1).ClearContents
    
    Arr = Sayfa2.Range("A1").CurrentRegion
    
    j = 1
    k = -1
    e = Arr(1, 1)
    ReDim diz(0)
    
    For i = LBound(Arr) To UBound(Arr)
        If e <> Arr(i, 1) Then
            j = j + 1
            Sayfa3.Cells(j, "A") = e
            Sayfa3.Range("B" & j).Resize(1, UBound(diz) + 1) = diz
            k = 0
            e = Arr(i, 1)
            Erase diz
            k = -1
        End If
        k = k + 1
        ReDim Preserve diz(k)
        diz(k) = Arr(i, 2)
        
    Next i
    
    j = j + 1
    Sayfa3.Cells(j, "A") = e
    Sayfa3.Range("B" & j).Resize(1, UBound(diz) + 1) = diz
  
    Debug.Print Time - t
    
    Application.ScreenUpdating = True
    
End Sub
 

tamer42

Destek Ekibi
Destek Ekibi
Katılım
11 Mart 2005
Mesajlar
3,059
Excel Vers. ve Dili
Office 2013 İngilizce
Merhaba,
Ben de sadece diziyle çalışan bir alternatif önereyim.

Dener misiniz?

Kod:
Sub DizilerleCalisma()

    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim e As Integer
    Dim Arr As Variant
    Dim diz As Variant
    Dim t
    t = Time
   
    Application.ScreenUpdating = False
   
    Sayfa3.Range("A1") = "İl"
    Sayfa3.Range("A1").CurrentRegion.Offset(1).ClearContents
   
    Arr = Sayfa2.Range("A1").CurrentRegion
   
    j = 1
    k = -1
    e = Arr(1, 1)
    ReDim diz(0)
   
    For i = LBound(Arr) To UBound(Arr)
        If e <> Arr(i, 1) Then
            j = j + 1
            Sayfa3.Cells(j, "A") = e
            Sayfa3.Range("B" & j).Resize(1, UBound(diz) + 1) = diz
            k = 0
            e = Arr(i, 1)
            Erase diz
            k = -1
        End If
        k = k + 1
        ReDim Preserve diz(k)
        diz(k) = Arr(i, 2)
       
    Next i
   
    j = j + 1
    Sayfa3.Cells(j, "A") = e
    Sayfa3.Range("B" & j).Resize(1, UBound(diz) + 1) = diz
 
    Debug.Print Time - t
   
    Application.ScreenUpdating = True
   
End Sub
Necdet Hocam teşekkürler,
burada benim amacım en hızlı çalışan çözüme ulaşmak,
çünkü çalıştığım dosyada veri sayısı çok fazla, 100 binler civarında...
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
diziler baya hızlı oluyor.
 

tamer42

Destek Ekibi
Destek Ekibi
Katılım
11 Mart 2005
Mesajlar
3,059
Excel Vers. ve Dili
Office 2013 İngilizce
diziler baya hızlı oluyor.
Büyük datalarda Dizi çok pratik oluyor Necdet Hocam,

Aslında bu yaptığım işlemin bir de tersi vardı. Ekli görseller de olduğu gibi... yatay veriyi, dikey veriye dönüştürme;

ekteki gibi bir kod oluşturdum ama; başta for ... next döngüsüne girmeden, öncelikle oluşacak tüm veriyi bir dizi içinde biriktirip en sonunda diziden hücrelere yapıştırmak gibi.

Kod:
Sub Dikey_Aktar()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim arr() As String

Dim i As Long, x As Long
Dim LR As Long
Dim j As Integer

Dim deger As String
Dim ad1 As String
Dim ad2 As String

Set Sh1 = Sayfa1
Set Sh2 = Sayfa2

Sh1.Activate

LR = Sh1.Cells(Sh1.Rows.Count, "A").End(xlUp).Row

Sh2.Activate
Sh2.Range("A2:H100000").ClearContents

x = 2
For i = 2 To LR
'''
ad1 = Sh1.Range("A" & i).Value
ad2 = Sh1.Range("B" & i).Value

deger = CStr(Sh1.Range("C" & i).Value)
  arr = Split(deger, "/")

    For j = LBound(arr) To UBound(arr)
    
        If Len(Trim(arr(j))) > 3 Then
        
                Sh2.Range("A" & x).Value = ad1
                Sh2.Range("B" & x).Value = ad2
                Sh2.Range("C" & x).Value = Trim(arr(j))
                
                x = x + 1
        
        End If
        
    Next j

Erase arr

Next i

Set Sh1 = Nothing
Set Sh2 = Nothing

End Sub
teşekkürler, iyi akşamlar.
 

Ekli dosyalar

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,105
Excel Vers. ve Dili
office2010
Ziynettin Hocam kusura bakmayın , yeni bir durum fark ettim, her il için ilk sıradaki ilçe bilgileri gelmiyor.
ekli dosyada görebilirsiniz,
Örnek: Adana Ceyhan' dan başlıyor, oysa Seyhan' dan başlamalı..

iyi çalışmalar.
Ekli dosyada ilçeleri 2. sıradan yazdığınız için kodu ona göre yazmıştım.

Kod:
Option Explicit
Private Sub ScriptDict()
Dim a(), b(), dc As Object, ds As Object, _
    sh1 As Worksheet, sh2 As Worksheet, _
    i As Long, j As Byte, sat As Long, sut As Byte, _
    il(), ilce(), deg, krt As String, LR As Long

Set sh1 = Sheets("Ilceler")
Set sh2 = Sheets("Yatay-Dizi")


Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")

LR = sh1.Cells(Rows.Count, 1).End(3).Row

a = sh1.Range("A1:B" & LR).Value

For i = 1 To UBound(a)
    krt = CStr(a(i, 1))
    dc(krt) = dc(krt) & "|" & a(i, 2)
    ds(krt) = ds(krt) + 1
Next i

il = dc.keys: ilce = dc.items
sat = dc.Count: sut = Application.Max(ds.items)

ReDim b(1 To sat, 1 To sut + 1)

For i = 1 To sat
    b(i, 1) = il(i - 1)
    deg = Split(ilce(i - 1), "|")
    For j = 1 To UBound(deg)
        b(i, j + 1) = deg(j)
    Next j
Next i


With sh2
    .Cells.ClearContents
    .Cells.ClearFormats
    .[A2].Resize(sat, sut) = b
    .[A2].Resize(sat, sut).EntireColumn.AutoFit
    .[A2].Resize(sat, sut).Borders.Color = rgbSilver
    .[A2].Resize(sat, sut).BorderAround , xlThin
    .[A2].Resize(sat).BorderAround , xlThin

End With

MsgBox "İşlem tamam.", vbInformation

End Sub
 

tamer42

Destek Ekibi
Destek Ekibi
Katılım
11 Mart 2005
Mesajlar
3,059
Excel Vers. ve Dili
Office 2013 İngilizce
Ekli dosyada ilçeleri 2. sıradan yazdığınız için kodu ona göre yazmıştım.

Kod:
Option Explicit
Private Sub ScriptDict()
Dim a(), b(), dc As Object, ds As Object, _
    sh1 As Worksheet, sh2 As Worksheet, _
    i As Long, j As Byte, sat As Long, sut As Byte, _
    il(), ilce(), deg, krt As String, LR As Long

Set sh1 = Sheets("Ilceler")
Set sh2 = Sheets("Yatay-Dizi")


Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")

LR = sh1.Cells(Rows.Count, 1).End(3).Row

a = sh1.Range("A1:B" & LR).Value

For i = 1 To UBound(a)
    krt = CStr(a(i, 1))
    dc(krt) = dc(krt) & "|" & a(i, 2)
    ds(krt) = ds(krt) + 1
Next i

il = dc.keys: ilce = dc.items
sat = dc.Count: sut = Application.Max(ds.items)

ReDim b(1 To sat, 1 To sut + 1)

For i = 1 To sat
    b(i, 1) = il(i - 1)
    deg = Split(ilce(i - 1), "|")
    For j = 1 To UBound(deg)
        b(i, j + 1) = deg(j)
    Next j
Next i


With sh2
    .Cells.ClearContents
    .Cells.ClearFormats
    .[A2].Resize(sat, sut) = b
    .[A2].Resize(sat, sut).EntireColumn.AutoFit
    .[A2].Resize(sat, sut).Borders.Color = rgbSilver
    .[A2].Resize(sat, sut).BorderAround , xlThin
    .[A2].Resize(sat).BorderAround , xlThin

End With

MsgBox "İşlem tamam.", vbInformation

End Sub
Ziynettin Hocam teşekkürler, iyiki varsınız

müsaadelerinizle bir soru daha sormak istiyorum
Ekli dosyada Yatay-Dizi (2) sayfasındaki formatta olduğu gibi;
"ilçe adı" ve "ilçe kodu" alt-alta ve her il için 2 satır olacak şekilde gelmesini nasıl sağlayabiliriz?

tekrar teşekkürler, iyi Çalışmalar.
 

Ekli dosyalar

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,105
Excel Vers. ve Dili
office2010
Buyrun..

Kod:
Sub ScriptDict()
Dim a(), b(), dc As Object, ds As Object, _
    sh1 As Worksheet, sh2 As Worksheet, _
    i As Long, j As Byte, sat As Long, sut As Byte, _
    il(), ilce(), deg, krt As String, LR As Long

Set sh1 = Sheets("Ilceler")
Set sh2 = Sheets("Yatay-Dizi (2)")


Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")

LR = sh1.Cells(Rows.Count, 1).End(3).Row

a = sh1.Range("A1:C" & LR).Value

For i = 1 To UBound(a)
    krt = CStr(a(i, 1))
    dc(krt) = dc(krt) & "|" & a(i, 2) & "#" & a(i, 3)
    ds(krt) = ds(krt) + 1
Next i

il = dc.keys: ilce = dc.items
sat = dc.Count: sut = Application.Max(ds.items) + 1

ReDim b(1 To sat * 2, 1 To sut)
k = 0
For i = 1 To sat Step 2
    b(i, 1) = il(k)
    b(i + 1, 1) = il(k)
    deg = Split(ilce(k), "|")
        For j = 1 To UBound(deg)
            b(i, j + 1) = Split(deg(j), "#")(0)
            b(i + 1, j + 1) = Split(deg(j), "#")(1)
        Next j
    k = k + 1
Next i

Application.ScreenUpdating = False
With sh2
    .Cells.ClearContents
    .Cells.ClearFormats
    .[A2].Resize(sat, sut) = b
    .[A2].Resize(sat, sut).EntireColumn.AutoFit
    .[A2].Resize(sat, sut).Borders.Color = rgbSilver
    .[A2].Resize(sat, sut).BorderAround , xlThin
    .[A2].Resize(sat).BorderAround , xlThin

End With
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub
 

tamer42

Destek Ekibi
Destek Ekibi
Katılım
11 Mart 2005
Mesajlar
3,059
Excel Vers. ve Dili
Office 2013 İngilizce
Buyrun..

Kod:
Sub ScriptDict()
Dim a(), b(), dc As Object, ds As Object, _
    sh1 As Worksheet, sh2 As Worksheet, _
    i As Long, j As Byte, sat As Long, sut As Byte, _
    il(), ilce(), deg, krt As String, LR As Long

Set sh1 = Sheets("Ilceler")
Set sh2 = Sheets("Yatay-Dizi (2)")


Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")

LR = sh1.Cells(Rows.Count, 1).End(3).Row

a = sh1.Range("A1:C" & LR).Value

For i = 1 To UBound(a)
    krt = CStr(a(i, 1))
    dc(krt) = dc(krt) & "|" & a(i, 2) & "#" & a(i, 3)
    ds(krt) = ds(krt) + 1
Next i

il = dc.keys: ilce = dc.items
sat = dc.Count: sut = Application.Max(ds.items) + 1

ReDim b(1 To sat * 2, 1 To sut)
k = 0
For i = 1 To sat Step 2
    b(i, 1) = il(k)
    b(i + 1, 1) = il(k)
    deg = Split(ilce(k), "|")
        For j = 1 To UBound(deg)
            b(i, j + 1) = Split(deg(j), "#")(0)
            b(i + 1, j + 1) = Split(deg(j), "#")(1)
        Next j
    k = k + 1
Next i

Application.ScreenUpdating = False
With sh2
    .Cells.ClearContents
    .Cells.ClearFormats
    .[A2].Resize(sat, sut) = b
    .[A2].Resize(sat, sut).EntireColumn.AutoFit
    .[A2].Resize(sat, sut).Borders.Color = rgbSilver
    .[A2].Resize(sat, sut).BorderAround , xlThin
    .[A2].Resize(sat).BorderAround , xlThin

End With
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub
Çok teşekkürler Hocam,
iyiki varsınız!
 
Üst