Alt alta veriyi yanyana Dizme Makrosu

[muysun35]

Herkese selamlar.

örnek dosyaya bir gözatıp yardımcı olabilecek arkadaşlar büyük sevaba girerler..

ilk 50 - 60 satır manuel olarak yapıldı.

kalan 8000 satır için yardım ederseniz....

 

[muysun35]

dosya linki
http://s6.dosya.tc/server3/wcw0xy/yardim.xlsx.html

 

[turist]

Örnek excel dosyanızı,açıklamalarını da yazarak; GOOGLE DRIVE, YANDEX DISK, DOSYA.WEB.TR , DOSYA.TC, DOSYA.CO gibi dosya paylaşım sitelerine ekleyip linkini burada bildirirseniz yardım almanız daha kolay olur.

 

[veyselemre]

Verilerinizi 1.satırdan başlatıp, Sayfa1 isimli bir sayfa ekleyip kodları deneyin.

Sub test()
    Sheets("Sayfa").Select
    Set dic1 = CreateObject("Scripting.Dictionary")
    son = Cells(Rows.Count, 1).End(3).Row
    With dic1
        For i = 1 To son
            x0 = .Item(Cells(i, "b").Value)
        Next i
        ver = .keys
        .RemoveAll
        For Each elem In ver
            x0 = .Item(Trim(Split(elem, ":")(0)))
        Next elem
        ver = .keys
        .RemoveAll
        For i = 0 To UBound(ver)
            .Item(ver(i)) = i + 1
        Next i
    End With

    Set dic2 = CreateObject("Scripting.Dictionary")
    Dim w()

    With dic2
        For i = 1 To son
            x0 = .Item(Cells(i, "a").Value)
        Next i
        ver = .keys
        .RemoveAll

        For ii = 0 To UBound(ver)
            .Item(ver(ii)) = ii + 1
        Next ii
    End With

    ReDim w(1 To dic2.Count, 1 To dic1.Count)

    For i = 1 To son
        ind1 = dic2.Item(Cells(i, "a").Value)
        ver = Cells(i, "b").Value
        key = Split(ver, ":")
        ind2 = dic1.Item(Trim(key(0)))
        ver = Trim(Replace(ver, key(0) & ":", ""))
        w(ind1, ind2) = ver
    Next i
    Sheets("Sayfa1").Select
    Sheets("Sayfa1").Cells.ClearContents
    ver = Application.Transpose(dic2.keys)
    [a2].Resize(dic2.Count, 1).Value = ver
    ver = dic1.keys
    [b1].Resize(1, dic1.Count).Value = ver
    [b2].Resize(dic2.Count, dic1.Count).Value = w
    Set dic1 = Nothing
    Set dic2 = Nothing
    Erase ver, w, key
End Sub

 

[Emir Hüseyin Çoban]

. . .

Dosyanız ektedir.

8 bin satır için işlem süresi çok uzun sürebilir, deneyiniz...

. . .

 

[muysun35]

. . .

Dosyanız ektedir.

8 bin satır için işlem süresi çok uzun sürebilir, deneyiniz...

. . .

Üstadım emeğinize sağlık ancak maalesef dosyayı indiremiyorum

zahmet olmazsa, başka bir dosya barındırıcıya yükleme şansınız olursa çok memnun oluruz.

 

[muysun35]

Verilerinizi 1.satırdan başlatıp, Sayfa1 isimli bir sayfa ekleyip kodları deneyin.

Veysel Emre emeğine sağlık. Kodlar sorunsuz şekilde çalışıyor.:dua2:


ama, veriyi ihtiyacım olan şekle getirmedi..

daha sonra bu hücreleri html kodları haline getireceğim için, örnekteki gibi olması gerekiyor.

ufak değişikliklerle örnek dosyadaki gibi yukarıda satır başı olmaksızın yanyana getirme şansımız olur mu?

 

[veyselemre]

Veysel Emre emeğine sağlık. Kodlar sorunsuz şekilde çalışıyor.:dua2:


ama, veriyi ihtiyacım olan şekle getirmedi..

daha sonra bu hücreleri html kodları haline getireceğim için, örnekteki gibi olması gerekiyor.

ufak değişikliklerle örnek dosyadaki gibi yukarıda satır başı olmaksızın yanyana getirme şansımız olur mu?

Sub test()
    Sheets("Sayfa").Select
    son = Cells(Rows.Count, 1).End(3).Row
    lst = Range("A1:B" & son).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To son
            key = lst(i, 1)
            If Not .exists(key) Then
                .Add key, key & "|" & lst(i, 2)
            Else
                .Item(key) = .Item(key) & "|" & lst(i, 2)
            End If
        Next i
        ver = (.items)
    End With

    Sheets("Sayfa1").Select
    Sheets("Sayfa1").Cells.ClearContents
    For i = 0 To UBound(ver)
        lst = Split(ver(i), "|")
        Cells(i + 1, 1).Resize(1, UBound(lst) + 1) = lst
    Next i
    Erase ver, lst

End Sub

 

[muysun35]

veysel emre kardeşim, eline emeğine sağlık.

çok işime yaradı..

Yardımın için teşekkürler.

(konu kilitlenebilir.)

 

[CXath1]

arkadaşlar merhaba. alt alta olan verilerden tarih kısmını yan yana almam lazım. yani şube ismi teke düşecek ve tarihler yan sütuna yazılacak. bu konuda yardımınızı rica ederim. teşekkürler..

örnek olarak;

ŞUBE TARİH
ACIBADEM 06.11.2015
ACIBADEM 08.11.2015
ADATEPE 05.11.2015
ADATEPE 07.11.2015
AKATLAR 03.11.2015
AKATLAR 05.11.2015
AKSARAY 02.11.2015
AKSARAY 04.11.2015
ATAKÖY ŞUBESİ 4.KISIM 02.11.2015
ATAKÖY ŞUBESİ 4.KISIM 04.11.2015
ATIŞALANI 02.11.2015
ATIŞALANI 04.11.2015
AVCILAR 04.11.2015
AVCILAR 06.11.2015
AVCILAR E5 02.11.2015
AVCILAR E5 04.11.2015
BAĞLARBAŞI 03.11.2015
BAĞLARBAŞI 05.11.2015
BAHÇEKAPI 04.11.2015
BAHÇEKAPI 06.11.2015
BAHÇEKAPI TİCARİ 04.11.2015
BAHÇEKAPI TİCARİ 06.11.2015
BAHÇELİEVLER 02.11.2015
BAHÇELİEVLER 04.11.2015
BAHÇELİEVLER 07.11.2015
BARBAROS BULVARI 02.11.2015
BARBAROS BULVARI 04.11.2015
BARBAROS BULVARI 07.11.2015
BATI ATAŞEHİR 05.11.2015
BATI ATAŞEHİR 07.11.2015
BATI ATAŞEHİR 10.11.2015
BAYRAMPAŞA 04.11.2015
BAYRAMPAŞA 06.11.2015
BAYRAMPAŞA 09.11.2015
BEŞİKTAŞ ARNAVUTKÖY ŞUEBESİ 06.11.2015
BEŞİKTAŞ ARNAVUTKÖY ŞUEBESİ 08.11.2015
BEŞİKTAŞ ARNAVUTKÖY ŞUEBESİ 11.11.2015
BÜYÜKÇEKMECE 02.11.2015
BÜYÜKÇEKMECE 04.11.2015
BÜYÜKÇEKMECE 07.11.2015

 

[Korhan Ayhan]

Deneyiniz.

Sub LİSTELE()
    Dim X As Long, Satir As Long, Sutun As Integer
    
    Application.ScreenUpdating = False
    
    Range("D:IV").ClearContents
    Range("D1") = "YENİ LİSTE"
    Satir = 2
    
    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        If WorksheetFunction.CountIf(Range("D:D"), Cells(X, "A")) = 0 Then
            Cells(Satir, "D") = Cells(X, "A")
            Sutun = Cells(Satir, Columns.Count).End(1).Column + 1
            Cells(Satir, Sutun) = Cells(X, "B")
            Satir = Satir + 1
        Else
            Set Bul = Range("D:D").Find(Cells(X, "A"), , , xlWhole)
            If Not Bul Is Nothing Then
                Sutun = Cells(Bul.Row, Columns.Count).End(1).Column + 1
                Cells(Bul.Row, Sutun) = Cells(X, "B")
            End If
        End If
    Next
    
    Cells.EntireColumn.AutoFit
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[veyselemre]

arkadaşlar merhaba. alt alta olan verilerden tarih kısmını yan yana almam lazım. yani şube ismi teke düşecek ve tarihler yan sütuna yazılacak. bu konuda yardımınızı rica ederim. teşekkürler..

Sub test()
    son = Cells(Rows.Count, 1).End(3).Row
    lst = Range("A2:B" & son).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To son - 1
            key = lst(i, 1)
            If Not .exists(key) Then
                .Add key, key & "|" & lst(i, 2)
            Else
                .Item(key) = .Item(key) & "|" & lst(i, 2)
            End If
        Next i
        ver = Application.Transpose(.items)
    End With

    Range("D2:IV65536").ClearContents
    With Range("D2").Resize(UBound(ver), 1)
        .Value = ver
        .TextToColumns Destination:=Range("D2"), Other:=True, OtherChar:="|"
    End With
    Cells.EntireColumn.AutoFit
    Erase ver, lst

End Sub