Makro ile transpose yapma

Katılım
13 Ocak 2021
Mesajlar
7
Excel Vers. ve Dili
Microsoft Office Professional Plus 2013 Türkçe
Merhabalar,

Elimde bir data var ve bu datayı tamamen çevirmek istiyorum :) ( bu verileri sql server'a import etmem gerektiği için tüm kolonların sabit olması gerekli ve bu gönderilen datadaki kolonlar her seferinde farklılaşıyor ben de bu yüzden "Dsn Bayi" kolonunun prim çeşidi kadar tekrar etmesini ve her bayi için prim çeşitlerinin tekrarlanmasını istiyorum )

İlk tablo gönderilen data, ikincisi ise çevirmek istediğm format. Makro ile birkaç şey denedim ama ne yaptıysam beceremedim çok mu zor bir şey istiyorum anlamadım :(

Dsn bayi

ASKERCELL PRİMİ EYLÜL

ÜST TARİFEYE GEÇİŞ PRİMİ KASIM

ÜST TARİFEYE GEÇİŞ PRİMİ SARKAN AĞUSTOS

GELİR SARKAN AĞUSTOS

PERAKENDECİLİK PRİMİ KASIM

PERAKENDECİLİK PRİMİ SARKAN EKİM

PERAKENDECİLİK PRİMİ SARKAN EYLÜL

KALİTELİ YÜKSEK ÖN ÖDEMELİ PRİMİ EKİM

RAHAT GELİR AVANS AĞUSTOS

RAHAT BAZ PRİM AVANS EYLÜL

BAZ PRİM SARKAN ÖN ÖDEMELİ EYLÜL

BAZ PRİM SARKAN FATURALI EYLÜL

ÖN ÖDEMELİ HAT İPTAL UYGULAMASI EKİM

RAHAT İPTAL UYGULAMASI EKİM

FATURALI İPTAL KESİNTİSİ MAYIS

DSN KESİLEMEYEN KASIM

GELIR PRIMI AVANS TURKCELL KASIM

AKTİVASYON TEŞVİK AVANS KASIM

BAZ PRIM ON ODEMELI KASIM

BAZ PRIM FATURALI KASIM

00000.B7580

0 TL

0 TL

0 TL

0 TL

4.800 TL

0 TL

0 TL

900 TL

0 TL

0 TL

1.987 TL

-90 TL

-280 TL

0 TL

0 TL

0 TL

5.191 TL

625 TL

6.600 TL

386 TL

00000.17400

0 TL

31 TL

199 TL

2.752 TL

4.400 TL

0 TL

0 TL

0 TL

7 TL

86 TL

66 TL

606 TL

0 TL

0 TL

0 TL

0 TL

2.138 TL

2.644 TL

1.375 TL

3.843 TL



Fakat bana aşağıdaki gibi bir data lazım,

Bayi

Prim Cesit

Prim Tutar

00000.B7580

ASKERCELL PRİMİ EYLÜL

0 TL

00000.B7580

ÜST TARİFEYE GEÇİŞ PRİMİ KASIM

0 TL

00000.B7580

ÜST TARİFEYE GEÇİŞ PRİMİ SARKAN AĞUSTOS

0 TL

00000.B7580

GELİR SARKAN AĞUSTOS

0 TL

00000.B7580

PERAKENDECİLİK PRİMİ KASIM

4.800 TL

00000.B7580

PERAKENDECİLİK PRİMİ SARKAN EKİM

0 TL

00000.B7580

PERAKENDECİLİK PRİMİ SARKAN EYLÜL

0 TL

00000.B7580

KALİTELİ YÜKSEK ÖN ÖDEMELİ PRİMİ EKİM

900 TL

00000.B7580

RAHAT GELİR AVANS AĞUSTOS

0 TL

00000.B7580

RAHAT BAZ PRİM AVANS EYLÜL

0 TL

00000.B7580

BAZ PRİM SARKAN ÖN ÖDEMELİ EYLÜL

1.987 TL

00000.B7580

BAZ PRİM SARKAN FATURALI EYLÜL

-90 TL

00000.B7580

ÖN ÖDEMELİ HAT İPTAL UYGULAMASI EKİM

-280 TL

00000.B7580

RAHAT İPTAL UYGULAMASI EKİM

0 TL

00000.B7580

FATURALI İPTAL KESİNTİSİ MAYIS

0 TL

00000.B7580

DSN KESİLEMEYEN KASIM

0 TL

00000.B7580

GELIR PRIMI AVANS TURKCELL KASIM

5.191 TL

00000.B7580

AKTİVASYON TEŞVİK AVANS KASIM

625 TL

00000.B7580

BAZ PRIM ON ODEMELI KASIM

6.600 TL

00000.B7580

BAZ PRIM FATURALI KASIM

386 TL

 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Merhaba,

Sorunuzu örnek dosya ekleyerek açıklayınız. Eski veri olması gereken düzen şeklinde.

 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++:
Option Explicit

Sub Transpose_Table()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant, Baslik As Variant
    Dim Son As Long, X As Long, Y As Byte, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Gelen Data")
    Set S2 = Sheets("Olması Gereken")
    
    S2.Range("A2:C" & S2.Rows.Count).Clear
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son <= 2 Then Son = 3
    
    Veri = S1.Range("A2:W" & Son).Value2
    Baslik = S1.Range("D1:" & S1.Cells(1, S1.Columns.Count).End(1).Address(0, 0)).Value
    
    ReDim Liste(1 To (Son - 1) * UBound(Baslik, 2), 1 To 3)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Y = LBound(Baslik, 2) To UBound(Baslik, 2)
            Say = Say + 1
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Baslik(1, Y)
            Liste(Say, 3) = Veri(X, Y + 3)
        Next
    Next
    
    If Say > 0 Then
        S2.Range("A2").Resize(Say, 1).NumberFormat = "@"
        S2.Range("A2").Resize(Say, 3) = Liste
        S2.Range("A2").Resize(Say, 3).Borders.LineStyle = 1
        S2.Columns.AutoFit
        MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
End Sub
 
Katılım
13 Ocak 2021
Mesajlar
7
Excel Vers. ve Dili
Microsoft Office Professional Plus 2013 Türkçe
Çok teşekkürler, tam istediğim şey oldu.

Adres verin çiçek yollayacağım :):)
 
Katılım
13 Ocak 2021
Mesajlar
7
Excel Vers. ve Dili
Microsoft Office Professional Plus 2013 Türkçe
Merhabalar,

Transpose için yazdığınız makroyu yeni bir dosyaya entegre etmek istediğimde hata alıyorum. Aşağıdaki gibi bir dosyam var ve alt alta bir data lazım bana. Yardımcı olabilir misiniz ?

Gelen Data

Tarih

1. BULVAR - 09:00

1. BULVAR - 18:00

1. BULVAR - 19:15

2. BULVAR - 09:00

2. BULVAR - 18:00

2. BULVAR - 19:15

01.06.2023​

1

1

 

1

1

 

02.06.2023​

1

1

 

1

1

 

03.06.2023​

1

1

 

1

1

 

04.06.2023​

1

1

    

05.06.2023​

1

1

 

1

1

1

06.06.2023​

1

1

 

1

1

1

07.06.2023​

1

1

 

1

1

1

08.06.2023​

1

1

 

1

1

1

09.06.2023​

1

1

 

1

1

1

10.06.2023​

1

1

 

1

1

 

11.06.2023​

1

1

 

1

1

 

12.06.2023​

      


Olması Gereken Data:

Tarih

Güzergah

Değer

1.06.2023​

1. BULVAR - 09:00

1

1.06.2023​

1. BULVAR - 18:00

1

1.06.2023​

1. BULVAR - 19:15

 

1.06.2023​

2. BULVAR - 09:00

1

1.06.2023​

2. BULVAR - 18:00

1

1.06.2023​

2. BULVAR - 19:15

 
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,180
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba.
2 nolu mesajı okuyunuz. :)
 

Necdet

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

Aşağıdaki kodları dener misiniz? Aynı Sayfa içinde I sütunundan itibaren yazar, siz kendinize uyarlayınız.

Kod:
Public Sub Duzenle()

Dim arr As Variant, _
    ard As Variant, _
    i   As Long, _
    j   As Long, _
    k   As Integer
    
i = Sheets("Data").Cells(Rows.Count, "A").End(3).Row - 1

arr = Range("A1").CurrentRegion.Value
ReDim ard(1 To (UBound(arr, 2) - 1) * i + 1, 1 To 3)

j = 1
ard(1, 1) = "Tarih"
ard(1, 2) = "Güzergah"
ard(1, 3) = "Değer"

For i = 2 To UBound(arr, 1)
    For k = 2 To UBound(arr, 2)
        j = j + 1
        ard(j, 1) = arr(i, 1)
        ard(j, 2) = arr(1, k)
        ard(j, 3) = arr(i, k)
    Next k
Next i

With Sheets("Data").Range("I1")
    .CurrentRegion.ClearContents
    .Resize(UBound(ard, 1), UBound(ard, 2)) = ard
End With

MsgBox "Tamamdır...."

End Sub
 
Son düzenleme:
Üst