Makro ile transpose yapma

[snmaybkehr]

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]

Merhaba,

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

Dosya Yükle - Dosya Upload

Dosyalarınızı ücretsiz yükleyebilir ve paylaşabilirsiniz. Dosya yükleme, Dosya Upload ücretsiz.

dosya.co

 

[snmaybkehr]

Merhaba,

Dosyayı yükledim. https://dosya.co/r6br0pp3bq3f/Dosya.xlsx.html

 

[Korhan Ayhan]

Deneyiniz.

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

 

[snmaybkehr]

Çok teşekkürler, tam istediğim şey oldu.

Adres verin çiçek yollayacağım

 

[snmaybkehr]

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]

Merhaba.
2 nolu mesajı okuyunuz.

 

[snmaybkehr]

MErhaba,

Dosyayı yükledim.

https://dosya.co/55aaa2qm95ft/S.A.H.K..xlsx.html

 

[Necdet]

Merhaba,

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

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