Veri Düzenleme

[Uzunkol]

Merhaba,
Arkadaşlar alt alta olan meteorolojik verileri yan yana aylara göre sıralamak istiyorum. Bunu özel yapıştırdan yapabiliyorum ancak elimde binlerce veri var ve çok zor oluyor. Bunu yapabileceğimiz bi kod var mı yardımcı olun lütfen. Ekteki dosyayı incelerseniz durumum daha iyi anlaşılır sanırım.

 

[Ömer]

Merhaba,

Veriler sıralı sanırım, eğer değilse belirtin ona göre yeniden düzenlerim.

Sub Duzenle()
    
    Dim sat As Long, i As Long
    
    Application.ScreenUpdating = False
    
    Range("D:D").ClearContents
    Range("E2:P" & Rows.Count).ClearContents
    
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D1" _
        ), Unique:=True
    
    sat = 2
    For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
        Range("C" & sat & ":C" & sat + 11).Copy
        Range("E" & i).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        sat = sat + 12
    Next i
    
    Range("A1").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
End Sub

.

 

[Uzunkol]

Çok teşekkür ederim ama bazı aylar eksik onun için çözüm var mı bu şekilde. yine ekte belirttim eksik olanlar mesela 8. ayın verisi yok ama yan yana sıralarken ağustos ayındaki hücreyi boş bırakacak ve verisi olan aydan devam edecek yine ekte belirttim eğer bunu çözebilirsek çok memnun olurum

 

[Ömer]

Bu şekilde deneyin.

Sub Duzenle()
    
    Dim sut As Byte, i As Long, c As Range, Adr As Variant
    
    Application.ScreenUpdating = False
    
    Range("D:D").ClearContents
    Range("E2:P" & Rows.Count).ClearContents
    
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=Range("D1"), Unique:=True
 
   For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
        sut = 5
        With Range("A:A")
            Set c = .Find(Cells(i, "D"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    Cells(i, sut + Cells(c.Row, "B") - 1) = Cells(c.Row, "C")
                Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
    Application.ScreenUpdating = True
    
End Sub

.

 

[Uzunkol]

Allah razı olsun valla çok makbule geçti. Çok iyi çalışıyor kod hocam biliyorum çok fazla oldum ama farklı bir işlem daha var onun içinde yardımcı olurmusunuz. sizede çok zahmet verdim ama. bu sorunda yine günlere göre olan değerleri sıramam gerekiyor. yine eksik günler en son yaptığımız işlemdeki gibi boş kalmalı. Yeterince yardımcı oldunuz biliyorum çok şey istiyorum Kusura bakmayın lütfen böyle bir yardıma ihtiyacım var yoksa bu verileri düzenlemek haftalarımı alır

 

[Ömer]

Tabiki yardımcı olurum. Yalnız biraz işim var bitirince kodları yazar paylaşırım.

 

[Uzunkol]

Tamam Teşşekkürler

 

[Uzunkol]

Bu şekilde deneyin.

Sub Duzenle()
    
    Dim sut As Byte, i As Long, c As Range, Adr As Variant
    
    Application.ScreenUpdating = False
    
    Range("D:D").ClearContents
    Range("E2:P" & Rows.Count).ClearContents
    
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=Range("D1"), Unique:=True
 
   For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
        sut = 5
        With Range("A:A")
            Set c = .Find(Cells(i, "D"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    Cells(i, sut + Cells(c.Row, "B") - 1) = Cells(c.Row, "C")
                Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
    Application.ScreenUpdating = True
    
End Sub

.

Hocam bu kodda yaşadığım bi sıkıntı var veriler a dan değilde b den başlıyor yanı yapılan herşey bir sonraki sütundan başlamalı ben düzeltmeye çalıştımda beceremedim. Ben dediğim şekliyle eke dosyayı koyuyorum

 

[Ömer]

Hocam bu kodda yaşadığım bi sıkıntı var veriler a dan değilde b den başlıyor yanı yapılan herşey bir sonraki sütundan başlamalı ben düzeltmeye çalıştımda beceremedim. Ben dediğim şekliyle eke dosyayı koyuyorum

Bu şekilde deneyin.

Sub Duzenle()
    
    Dim sut As Byte, i As Long, c As Range, Adr As Variant
    
    Application.ScreenUpdating = False
    
    Range("E:E").ClearContents
    Range("F2:Q" & Rows.Count).ClearContents
    
    Columns("B:B").AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=Range("E1"), Unique:=True
 
   For i = 2 To Cells(Rows.Count, "E").End(xlUp).Row
        sut = 6
        With Range("B:B")
            Set c = .Find(Cells(i, "E"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    Cells(i, sut + Cells(c.Row, "C") - 1) = Cells(c.Row, "D")
                Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
    Application.ScreenUpdating = True
    
End Sub

.

 

[Uzunkol]

Bu şekilde deneyin.

Sub Duzenle()
    
    Dim sut As Byte, i As Long, c As Range, Adr As Variant
    
    Application.ScreenUpdating = False
    
    Range("E:E").ClearContents
    Range("F2:Q" & Rows.Count).ClearContents
    
    Columns("B:B").AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=Range("E1"), Unique:=True
 
   For i = 2 To Cells(Rows.Count, "E").End(xlUp).Row
        sut = 6
        With Range("B:B")
            Set c = .Find(Cells(i, "E"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    Cells(i, sut + Cells(c.Row, "C") - 1) = Cells(c.Row, "D")
                Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
    Application.ScreenUpdating = True
    
End Sub

.

Çok saol problem çözülmüştür. Hocam şimdi tek sorun günlere göre olan veriler onuda sayenizde çözeceğiz

 

[Uzunkol]

Kusura bakmayın rahatsız ediyorum gene günlük verileri düzenleme olmuyor mu bilgi verir misiniz. Geçekten ihtiyacım var buna inanılmaz bir veri karmaşası var özellikle günlük bazda olunca çok sıkıntı yaşıyorum yardımlarınız bekliyorum

 

[Uzunkol]

Kusura bakmayın yine rahatsız ediyorum. Günlük verilerin kodu olmuyormu. Gerçekten ihtiyacım var buna çok fazla veri karmaşası var yardımlarınızı bekliyorum

 

[Ömer]

Bu şekilde deneyin. Ek olarak bu tür tablolarda makro yerine excelin kendi işlevi olan özet tabloyu kullanmanızı tavsiye ederim.

Sub OzetListe()
 
    Dim dizi2(1 To 31) As Byte, i As Long, d As Object, dizi1, a1, deg
    Dim sat As Long, sut As Integer, c As Range, Adr As Variant, j As Byte
    
    Application.ScreenUpdating = False
    
    dizi1 = Array("Gün/Ay", "Ocak", "Şubat", "Mart", "Nisan", "Mayıs", _
        "Haziran", "Temmuz", "Ağustos", "Eylül", "Ekim", "Kasım", "Aralık")
        
    For i = 1 To 31
        dizi2(i) = i
    Next i
 
    Set d = CreateObject("Scripting.Dictionary")
    
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        End If
    Next i
 
    Range("F:R").ClearContents
    a1 = d.keys: sat = 1
 
    For i = 0 To d.Count - 1
        Cells(sat, "F") = a1(i)
        Cells(sat + 1, "F").Resize(1, UBound(dizi1) + 1) = dizi1
        Cells(sat + 2, "F").Resize(UBound(dizi2), 1) = WorksheetFunction.Transpose(dizi2)
        sat = sat + 35
    Next i
    
    For i = 1 To Cells(Rows.Count, "F").End(xlUp).Row Step 35
        sut = 6
        With Range("B:B")
            Set c = .Find(Cells(i, "F"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    For j = 1 To 31
                        If Cells(c.Row, "D") = j Then
                            Cells(j + i + 1, sut + Cells(c.Row, "C")) = Cells(c.Row, "E")
                        End If
                    Next j
                Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
 
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam", , "excel.web.tr"
 
End Sub

.

 

[Uzunkol]

Teşekkür ederim on numara olmuş. Özet tabloyu istediğim şekilde ayarlayamadım o yüzden makro istiyorum. Hocam bide bunu çalışma kitabının tüm sayfalarına aynı anda uygulama imkanımız varmı