Sütunları alt alta sıralama hk yardım

canigdeli · 16 Haziran 2020

Merhaba Bir araştırma datasındaki verileri tek sütun altında sıralamam gerekiyor yardımınıza ihtiyacım var eğer yardımcı olabilirseniz çok sevinirim.
Benzer konulardaki cevaplardaki makroları kendi çalışmama uyarlamayı denedim ancak hangi verileri makroya yerleştireceğimi çözemedim.
Yapmak istediğim tablodaki verileri başladığı yıldan sona kadar sıralamak. Çalışmanın tümüne uygulanabilecek bir makro önerisi de olabilir veya tarih kısmını manuel yazıp, her yıl için tabloyu seçip değerleri tarihlerin yanına sıralayabilecek bir makro da olabilir.
Destek olursanız manuel olarak sıraladığım sütunları sizin sayenizde kısa sürede halledip esas konuma başlayabileceğim.
Şimdiden teşekkürler .

Linki bu şekilde ekliyorum ortalama sıcaklık
veya https://drive.google.com/file/d/1tlK2t0cYD2KfBkBlR87DAMtH-DBm8ezA/view?usp=sharing

YUSUF44 · 16 Haziran 2020

Dosyanızda nasıl bir sonuç istediğinizi de belirtin lütfen.

canigdeli · 16 Haziran 2020

YUSUF44' Alıntı:
Dosyanızda nasıl bir sonuç istediğinizi de belirtin lütfen.

Aynı istasyona ait verileri ilk yıldan son yıla kadar gün gün sıralamak örneğin 1983 AKSU KK tablosundan 01.01.1983 gününde -5,9 verisi ile başlayıp aşağı doğru sıralamak.

en basit anlamda anlatmam gerekirse her yıl için 1,2,3,...,12 nolu sütunların 1 nolu sütun altında sıralanmasına ihtiyacım var. (Veri olmayan günlerin olduğunu hatırlatmak isterim)

YUSUF44 · 16 Haziran 2020

Dosyanıza bir sayfa ekleyin, adı Sayfa1 olsun

Aşağıdaki kodları bir modüle kopyalayıp deneyin. Makro Sayfa1'in A sütununa istasyon adını, B sütununa yılı, C sütununa ayı, D sütununa günü, E sütununa tarihi ve F sütununa da ortalama sıcaklığı kaydeder:

PHP:

Sub meteo()
Set s1 = Sheets("Report")
Set s2 = Sheets("Sayfa1")
son = s1.Cells(Rows.Count, "B").End(3).Row
Application.ScreenUpdating = False
For yil = 3 To son Step 39
    sene = Mid(s1.Cells(yil, "B"), 6, 4)
    istasyon = Trim(Mid(s1.Cells(yil, "B"), 29, Len(s1.Cells(yil, "B"))))
    For ay = 3 To 14
        For gun = 0 To 30
            If Len(s1.Cells(yil + 4 + gun, ay)) > 0 Then
                yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
                s2.Cells(yeni, "A") = istasyon
                s2.Cells(yeni, "B") = sene
                s2.Cells(yeni, "C") = ay - 2
                s2.Cells(yeni, "D") = gun + 1
                s2.Cells(yeni, "E") = DateSerial(sene * 1, ay - 2, gun + 1)
                s2.Cells(yeni, "F") = s1.Cells(yil + 4 + gun, ay)
            End If
        Next
    Next
Next
Application.ScreenUpdating = True
s2.Activate
MsgBox "İşlem tamamlandı"
End Sub

canigdeli · 16 Haziran 2020

YUSUF44' Alıntı:

Dosyanıza bir sayfa ekleyin, adı Sayfa1 olsun

Aşağıdaki kodları bir modüle kopyalayıp deneyin. Makro Sayfa1'in A sütununa istasyon adını, B sütununa yılı, C sütununa ayı, D sütununa günü, E sütununa tarihi ve F sütununa da ortalama sıcaklığı kaydeder:

PHP:

Sub meteo()
Set s1 = Sheets("Report")
Set s2 = Sheets("Sayfa1")
son = s1.Cells(Rows.Count, "B").End(3).Row
Application.ScreenUpdating = False
For yil = 3 To son Step 39
    sene = Mid(s1.Cells(yil, "B"), 6, 4)
    istasyon = Trim(Mid(s1.Cells(yil, "B"), 29, Len(s1.Cells(yil, "B"))))
    For ay = 3 To 14
        For gun = 0 To 30
            If Len(s1.Cells(yil + 4 + gun, ay)) > 0 Then
                yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
                s2.Cells(yeni, "A") = istasyon
                s2.Cells(yeni, "B") = sene
                s2.Cells(yeni, "C") = ay - 2
                s2.Cells(yeni, "D") = gun + 1
                s2.Cells(yeni, "E") = DateSerial(sene * 1, ay - 2, gun + 1)
                s2.Cells(yeni, "F") = s1.Cells(yil + 4 + gun, ay)
            End If
        Next
    Next
Next
Application.ScreenUpdating = True
s2.Activate
MsgBox "İşlem tamamlandı"
End Sub

Yusuf Bey çok teşekkür ederim makro çalıştı bu haliyle de işimi son derece kolaylaştırdı.
son olarak bir ilave daha sorabilir miyim?
veriyi İstasyon bazında ayrı sekmelere çekebilir miyiz? Makroya bunu ekleyebilmek mümkün mü?

YUSUF44 · 16 Haziran 2020

Sayfa1in A1 hücresine İstasyon, B1 hücresine Yıl, C1 hücresine Ay, D1 hücresine Gün, E1 hücresine Tarih ve F1 hücresine Ortalama yazın. Bunalr sütun başlıkları olacak. Birebir aynı yazmaya dikkat edin, fazladan boşluk vs olmasın. Daha sonra aşağıdaki kodları bir modüle kopyalayıp çalıştırın. Sayfa1'de veri yoksa önce sayfa1'i oluşturur, sonra da istediğiniz gibi sayfalara böler:

PHP:

Sub sayfalara_ayir()
Set s1 = Sheets("Sayfa1")
If s1.Cells(Rows.Count, "A").End(3).Row = 1 Then
    Call meteo
End If
Application.ScreenUpdating = False
    son = s1.Cells(Rows.Count, "A").End(3).Row
    For i = 2 To son
        If WorksheetFunction.CountIf(s1.Range("A1:A" & i), s1.Cells(i, "A")) = 1 Then
            son = s1.Cells(Rows.Count, "A").End(3).Row
            Set con = VBA.CreateObject("adodb.Connection")
            For sayfa = 1 To Sheets.Count
                If Sheets(sayfa).Name = Replace(s1.Cells(i, "A"), "/", "") Then GoTo 10
            Next
            Sheets.Add After:=Sheets(Sheets.Count)
            s1.Rows("1:1").Copy ActiveSheet.[A1]
           
            con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
            ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
           
            sorgu = "select İstasyon,Yıl, Ay,Gün,Tarih,Ortalama " & _
              "from[" & s1.Name & "$] where [İstasyon] ='" & s1.Cells(i, "A") & "'"
           
            Set rs = con.Execute(sorgu)
           
            ActiveSheet.[A2].CopyFromRecordset rs
            ActiveSheet.Name = Replace(s1.Cells(i, "A"), "/", "")
            ActiveSheet.Columns("A:F").EntireColumn.AutoFit
        End If
10:
    Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı"
End Sub

canigdeli · 16 Haziran 2020

YUSUF44' Alıntı:

Sayfa1in A1 hücresine İstasyon, B1 hücresine Yıl, C1 hücresine Ay, D1 hücresine Gün, E1 hücresine Tarih ve F1 hücresine Ortalama yazın. Bunalr sütun başlıkları olacak. Birebir aynı yazmaya dikkat edin, fazladan boşluk vs olmasın. Daha sonra aşağıdaki kodları bir modüle kopyalayıp çalıştırın. Sayfa1'de veri yoksa önce sayfa1'i oluşturur, sonra da istediğiniz gibi sayfalara böler:

PHP:

Set s1 = Sheets("Sayfa1")
If s1.Cells(Rows.Count, "A").End(3).Row = 1 Then
    Call meteo
End If
Application.ScreenUpdating = False
    son = s1.Cells(Rows.Count, "A").End(3).Row
    For i = 2 To son
        If WorksheetFunction.CountIf(s1.Range("A1:A" & i), s1.Cells(i, "A")) = 1 Then
            son = s1.Cells(Rows.Count, "A").End(3).Row
            Set con = VBA.CreateObject("adodb.Connection")
            For sayfa = 1 To Sheets.Count
                If Sheets(sayfa).Name = Replace(s1.Cells(i, "A"), "/", "") Then GoTo 10
            Next
            Sheets.Add After:=Sheets(Sheets.Count)
            s1.Rows("1:1").Copy ActiveSheet.[A1]
           
            con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
            ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
           
            sorgu = "select İstasyon,Yıl, Ay,Gün,Tarih,Ortalama " & _
              "from[" & s1.Name & "$] where [İstasyon] ='" & s1.Cells(i, "A") & "'"
           
            Set rs = con.Execute(sorgu)
           
            ActiveSheet.[A2].CopyFromRecordset rs
            ActiveSheet.Name = Replace(s1.Cells(i, "A"), "/", "")
            ActiveSheet.Columns("A:F").EntireColumn.AutoFit
        End If
10:
    Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı"
End Sub

Yusuf Bey kusura bakmayın başlangıç soruları soruyorum ama 2 kodu ayrı mı çalıştırmalıyım yoksa son kodla tüm yapmak istediğimi yapabilecek miyim? 2.kodu çalıştıramadım

YUSUF44 · 16 Haziran 2020

Son kod eğer Sayfa1'de hiç veri yoksa önce sayfa1'e verileri aktarır, sonra sayfalara ayırır. Sayfa1'de en az 1 satır veri varsa sayfa1'deki verilere göre işlem yapar.

canigdeli · 16 Haziran 2020

YUSUF44' Alıntı:
Son kod eğer Sayfa1'de hiç veri yoksa önce sayfa1'e verileri aktarır, sonra sayfalara ayırır. Sayfa1'de en az 1 satır veri varsa sayfa1'deki verilere göre işlem yapar.

Sayfa1 A1 hücresinden başlayıp Sütun başlıklarını harfiyen yazdım sonrasında Kodu modül içine yazıp çalıştır (run) tıkladığımda fotoğrafta göreceğiniz küçük pencere açılıyor. (1.link) Bir isim vermeyi deneyip create dediğimdeki adım şu şekilde (2.link)

1. link :https://drive.google.com/file/d/1Poh0x8xtoJk_nT-K_dGVPJUIK2hTUKU5/view?usp=sharing
2:link:https://drive.google.com/file/d/1tSxQY1h8xfTj765mpLPsA5gQOO9SAdzr/view?usp=sharing

YUSUF44 · 16 Haziran 2020

Makronun adının olduğu ilk satırı kopyalamayı unutmuşum????
Yukardaki kodu güncelledim. Tekrar bakın.

Korhan Ayhan · 16 Haziran 2020

Alternatif;

Hız olarak avantaj sağlayacaktır.

C++:

Option Explicit

Sub Analiz()
    Dim Dizi As Object, S1 As Worksheet, S2 As Worksheet, Sayfa As Worksheet, Veri As Variant
    Dim Son As Long, X As Long, Y As Integer, Say As Long, Metin As Variant, Istasyon As Variant
    Dim Yil As Integer, İstasyon_Adi As String, İstasyon_No As Long, Z As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Report")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    On Error Resume Next
    Application.DisplayAlerts = False
        For Each Sayfa In ThisWorkbook.Worksheets
            If Sayfa.Name <> "Report" Then Sayfa.Delete
        Next
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son = 1 Then Son = 2
    Veri = S1.Range("B1:N" & Son).Value

    ReDim Liste(1 To S1.Rows.Count, 1 To 6)
    Say = 1
    
    Liste(Say, 1) = "İSTASYON ADI"
    Liste(Say, 2) = "İSTASYON NO"
    Liste(Say, 3) = "YIL"
    Liste(Say, 4) = "AY"
    Liste(Say, 5) = "GÜN"
    Liste(Say, 6) = "GÜNLÜK ORTALAMA SICAKLIK"
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Left(Veri(X, 1), 3) = "Yıl" Then
            Yil = Mid(Veri(X, 1), 6, 4)
            Metin = Split(Veri(X, 1), ": ")
            Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            İstasyon_Adi = Metin
            If InStr(1, Metin, "/") > 0 Then
                Metin = Split(Veri(X, 1), "/")
                Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            End If
            İstasyon_No = Metin
            İstasyon_Adi = WorksheetFunction.Trim(Replace(İstasyon_Adi, "/" & Metin, ""))
            For Y = LBound(Veri, 2) + 1 To UBound(Veri, 2)
                For Z = X + 4 To X + 34
                    If Veri(Z, Y) <> Empty Then
                        Say = Say + 1
                        Liste(Say, 1) = İstasyon_Adi
                        Liste(Say, 2) = İstasyon_No
                        Liste(Say, 3) = Yil
                        Liste(Say, 4) = Veri(X + 3, Y)
                        Liste(Say, 5) = Veri(Z, 1)
                        Liste(Say, 6) = Veri(Z, Y)
                    End If
                Next
            Next
        End If
    Next

    If Say > 0 Then
        Set S2 = Sheets.Add(, S1)
        S2.Name = "Analiz"
        S2.Range("A1").Resize(Say, 6) = Liste
        S2.Range("A1:F1").Font.Bold = True
        S2.Range("A1:F1").Font.ColorIndex = 3
        S2.Range("A1:F1").HorizontalAlignment = xlCenter
        S2.Columns.AutoFit
        
        Veri = S2.Range("A2:A" & Say).Value
        
        For X = LBound(Veri) To UBound(Veri)
            Dizi.Item(Veri(X, 1)) = 1
        Next
    
        For Each Istasyon In Dizi.Keys
            S2.Range("A1").AutoFilter 1, Istasyon
            Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Sheets.Add , Sheets(Sheets.Count)
                ActiveSheet.Name = Replace(Left(Istasyon, 30), "/", "-")
                S2.Range("A1").CurrentRegion.Copy Range("A1")
                Cells.Columns.AutoFit
            End If
        Next
    End If
        
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    S1.Select
        
    Set S1 = Nothing
    Set S2 = Nothing
        
    Application.ScreenUpdating = True

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

canigdeli · 17 Haziran 2020

YUSUF44' Alıntı:
Makronun adının olduğu ilk satırı kopyalamayı unutmuşum????
Yukardaki kodu güncelledim. Tekrar bakın.

Yusuf Bey günaydın,
ÇAlıştıramadım

Compile error: Sub or Function not defined hatası veriyor

canigdeli · 17 Haziran 2020

Korhan Ayhan' Alıntı:

Alternatif;

Hız olarak avantaj sağlayacaktır.

C++:

Option Explicit

Sub Analiz()
    Dim Dizi As Object, S1 As Worksheet, S2 As Worksheet, Sayfa As Worksheet, Veri As Variant
    Dim Son As Long, X As Long, Y As Integer, Say As Long, Metin As Variant, Istasyon As Variant
    Dim Yil As Integer, İstasyon_Adi As String, İstasyon_No As Long, Z As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("Report")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    On Error Resume Next
    Application.DisplayAlerts = False
        For Each Sayfa In ThisWorkbook.Worksheets
            If Sayfa.Name <> "Report" Then Sayfa.Delete
        Next
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son = 1 Then Son = 2
    Veri = S1.Range("B1:N" & Son).Value

    ReDim Liste(1 To S1.Rows.Count, 1 To 6)
    Say = 1
   
    Liste(Say, 1) = "İSTASYON ADI"
    Liste(Say, 2) = "İSTASYON NO"
    Liste(Say, 3) = "YIL"
    Liste(Say, 4) = "AY"
    Liste(Say, 5) = "GÜN"
    Liste(Say, 6) = "GÜNLÜK ORTALAMA SICAKLIK"
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Left(Veri(X, 1), 3) = "Yıl" Then
            Yil = Mid(Veri(X, 1), 6, 4)
            Metin = Split(Veri(X, 1), ": ")
            Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            İstasyon_Adi = Metin
            If InStr(1, Metin, "/") > 0 Then
                Metin = Split(Veri(X, 1), "/")
                Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            End If
            İstasyon_No = Metin
            İstasyon_Adi = WorksheetFunction.Trim(Replace(İstasyon_Adi, "/" & Metin, ""))
            For Y = LBound(Veri, 2) + 1 To UBound(Veri, 2)
                For Z = X + 4 To X + 34
                    If Veri(Z, Y) <> Empty Then
                        Say = Say + 1
                        Liste(Say, 1) = İstasyon_Adi
                        Liste(Say, 2) = İstasyon_No
                        Liste(Say, 3) = Yil
                        Liste(Say, 4) = Veri(X + 3, Y)
                        Liste(Say, 5) = Veri(Z, 1)
                        Liste(Say, 6) = Veri(Z, Y)
                    End If
                Next
            Next
        End If
    Next

    If Say > 0 Then
        Set S2 = Sheets.Add(, S1)
        S2.Name = "Analiz"
        S2.Range("A1").Resize(Say, 6) = Liste
        S2.Range("A1:F1").Font.Bold = True
        S2.Range("A1:F1").Font.ColorIndex = 3
        S2.Range("A1:F1").HorizontalAlignment = xlCenter
        S2.Columns.AutoFit
       
        Veri = S2.Range("A2:A" & Say).Value
       
        For X = LBound(Veri) To UBound(Veri)
            Dizi.Item(Veri(X, 1)) = 1
        Next
   
        For Each Istasyon In Dizi.Keys
            S2.Range("A1").AutoFilter 1, Istasyon
            Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Sheets.Add , Sheets(Sheets.Count)
                ActiveSheet.Name = Replace(Left(Istasyon, 30), "/", "-")
                S2.Range("A1").CurrentRegion.Copy Range("A1")
                Cells.Columns.AutoFit
            End If
        Next
    End If
       
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    S1.Select
       
    Set S1 = Nothing
    Set S2 = Nothing
       
    Application.ScreenUpdating = True

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan Bey çok teşekkürler bu komutla çok hızlı sonuç aldım
Son 2 soru ile sizin vaktinizi son kez alacağım.
ilki: Sizin kod ile sekmeleri ayırırken istasyon adları yazsa ve sekmedeki veri sadece gün ay yıl (tek hücrede) ve değer olsa kodu nasıl değiştirmeliyim? Yani sadece 2 sütun olması yeterli.

2. olarak Günlük ortalama sıcaklık verisi Yağış, Buhar basıncı ile değiştiğinde Liste(Say, 6) = "GÜNLÜK ORTALAMA SICAKLIK" kısmında değişiklik yapmam yeterli olacak değil mi?

canigdeli · 17 Haziran 2020

Korhan Ayhan' Alıntı:

Alternatif;

Hız olarak avantaj sağlayacaktır.

C++:

Option Explicit

Sub Analiz()
    Dim Dizi As Object, S1 As Worksheet, S2 As Worksheet, Sayfa As Worksheet, Veri As Variant
    Dim Son As Long, X As Long, Y As Integer, Say As Long, Metin As Variant, Istasyon As Variant
    Dim Yil As Integer, İstasyon_Adi As String, İstasyon_No As Long, Z As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("Report")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    On Error Resume Next
    Application.DisplayAlerts = False
        For Each Sayfa In ThisWorkbook.Worksheets
            If Sayfa.Name <> "Report" Then Sayfa.Delete
        Next
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son = 1 Then Son = 2
    Veri = S1.Range("B1:N" & Son).Value

    ReDim Liste(1 To S1.Rows.Count, 1 To 6)
    Say = 1
   
    Liste(Say, 1) = "İSTASYON ADI"
    Liste(Say, 2) = "İSTASYON NO"
    Liste(Say, 3) = "YIL"
    Liste(Say, 4) = "AY"
    Liste(Say, 5) = "GÜN"
    Liste(Say, 6) = "GÜNLÜK ORTALAMA SICAKLIK"
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Left(Veri(X, 1), 3) = "Yıl" Then
            Yil = Mid(Veri(X, 1), 6, 4)
            Metin = Split(Veri(X, 1), ": ")
            Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            İstasyon_Adi = Metin
            If InStr(1, Metin, "/") > 0 Then
                Metin = Split(Veri(X, 1), "/")
                Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            End If
            İstasyon_No = Metin
            İstasyon_Adi = WorksheetFunction.Trim(Replace(İstasyon_Adi, "/" & Metin, ""))
            For Y = LBound(Veri, 2) + 1 To UBound(Veri, 2)
                For Z = X + 4 To X + 34
                    If Veri(Z, Y) <> Empty Then
                        Say = Say + 1
                        Liste(Say, 1) = İstasyon_Adi
                        Liste(Say, 2) = İstasyon_No
                        Liste(Say, 3) = Yil
                        Liste(Say, 4) = Veri(X + 3, Y)
                        Liste(Say, 5) = Veri(Z, 1)
                        Liste(Say, 6) = Veri(Z, Y)
                    End If
                Next
            Next
        End If
    Next

    If Say > 0 Then
        Set S2 = Sheets.Add(, S1)
        S2.Name = "Analiz"
        S2.Range("A1").Resize(Say, 6) = Liste
        S2.Range("A1:F1").Font.Bold = True
        S2.Range("A1:F1").Font.ColorIndex = 3
        S2.Range("A1:F1").HorizontalAlignment = xlCenter
        S2.Columns.AutoFit
       
        Veri = S2.Range("A2:A" & Say).Value
       
        For X = LBound(Veri) To UBound(Veri)
            Dizi.Item(Veri(X, 1)) = 1
        Next
   
        For Each Istasyon In Dizi.Keys
            S2.Range("A1").AutoFilter 1, Istasyon
            Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Sheets.Add , Sheets(Sheets.Count)
                ActiveSheet.Name = Replace(Left(Istasyon, 30), "/", "-")
                S2.Range("A1").CurrentRegion.Copy Range("A1")
                Cells.Columns.AutoFit
            End If
        Next
    End If
       
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    S1.Select
       
    Set S1 = Nothing
    Set S2 = Nothing
       
    Application.ScreenUpdating = True

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Datayı hızlı bir şekilde ayırabildim çok teşekkürler Korhan Bey. Manuel olarak 5-6 ay sürede bitirebileceğim bir datayı çok kısa sürede halledip raporlama aşamasına geçebileceğim.
Farklı Tablolarda veri olmayan günler var buralarda tarihi getirip boşluk getirmeli, sıfır değerleri zaten sıfır olarak getirecektir.
Tekrar kusura bakmayın sizi uğraştıracağım

Korhan Ayhan · 17 Haziran 2020

Aşağıdaki soruları cevaplarsanız hızlı sonuç alabiliriz.

1-Analiz sayfasında bir değişiklik olacak mı?

2-Sayfalara ayırırken zaten istasyon adı kullanılıyor. Buradaki sorunu anlamadım?

3-Başlıkları değiştirmek için çift tırnak içindeki metinsel ifadeleri dilediğiniz gibi düzenleyebilirsiniz.

4-Bazı aylarda hiç bilgi yok, bazı aylarda bazı günlerde hiç bilgi yok. Bu durumda tabloda bulunan bütün günler mi listelenecek?

canigdeli · 17 Haziran 2020

Korhan Ayhan' Alıntı:
Aşağıdaki soruları cevaplarsanız hızlı sonuç alabiliriz.

1-Analiz sayfasında bir değişiklik olacak mı? Analiz sayfasında bir değişiklik olmayacak

2-Sayfalara ayırırken zaten istasyon adı kullanılıyor. Buradaki sorunu anlamadım? istasyon bazındaki sekmelerde sadece tarih (gün.ay.yıl) ve değer olacak şekilde 2 sütun olması yeterli

3-Başlıkları değiştirmek için çift tırnak içindeki metinsel ifadeleri dilediğiniz gibi düzenleyebilirsiniz. teşekkürler bunu çözebildim.

4-Bazı aylarda hiç bilgi yok, bazı aylarda bazı günlerde hiç bilgi yok. Bu durumda tabloda bulunan bütün günler mi listelenecek? evet değer olmayanlar da listenmesi lazım.

Korhan Bey cevapları renkli olarak yazdım. Teşekkür ederim şimdiden.

YUSUF44 · 17 Haziran 2020

canigdeli' Alıntı:
Korhan Bey cevapları renkli olarak yazdım. Teşekkür ederim şimdiden.

Eğer veri olmayan değerler de listelenecekse #3 nolu mesajdaki ifadenizdeki amacınız neydi? Ben bunu, veri olmayanlar listelenmeyecek olarak anlamıştım:

canigdeli' Alıntı:
Aynı istasyona ait verileri ilk yıldan son yıla kadar gün gün sıralamak örneğin 1983 AKSU KK tablosundan 01.01.1983 gününde -5,9 verisi ile başlayıp aşağı doğru sıralamak.

en basit anlamda anlatmam gerekirse her yıl için 1,2,3,...,12 nolu sütunların 1 nolu sütun altında sıralanmasına ihtiyacım var. (Veri olmayan günlerin olduğunu hatırlatmak isterim)

Korhan Ayhan · 17 Haziran 2020

Deneyiniz.

Olmayan yer varsa düzenleriz.

C++:

Option Explicit

Sub Analiz()
    Dim Dizi As Object, S1 As Worksheet, S2 As Worksheet, Sayfa As Worksheet, Veri As Variant
    Dim Son As Long, X As Long, Y As Integer, Say As Long, Metin As Variant, Istasyon As Variant, Sayfa_Adi As String
    Dim Yil As Integer, Tarih As Date, Istasyon_Adi As String, Istasyon_No As Long, Z As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("Report")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    On Error Resume Next
    Application.DisplayAlerts = False
        For Each Sayfa In ThisWorkbook.Worksheets
            If Sayfa.Name <> "Report" Then Sayfa.Delete
        Next
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son = 1 Then Son = 2
    Veri = S1.Range("B1:N" & Son).Value

    ReDim Liste(1 To S1.Rows.Count, 1 To 4)
    Say = 1
   
    Liste(Say, 1) = "İSTASYON ADI"
    Liste(Say, 2) = "İSTASYON NO"
    Liste(Say, 3) = "TARİH"
    Liste(Say, 4) = "GÜNLÜK ORTALAMA SICAKLIK"
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Left(Veri(X, 1), 3) = "Yıl" Then
            Yil = Mid(Veri(X, 1), 6, 4)
            Metin = Split(Veri(X, 1), ": ")
            Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            Istasyon_Adi = Metin
            If InStr(1, Metin, "/") > 0 Then
                Metin = Split(Veri(X, 1), "/")
                Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            End If
            Istasyon_No = Metin
            Istasyon_Adi = WorksheetFunction.Trim(Replace(Istasyon_Adi, "/" & Metin, ""))
            For Y = LBound(Veri, 2) + 1 To UBound(Veri, 2)
                For Z = X + 4 To X + 34
                    If Month(DateSerial(Yil, Veri(X + 3, Y), Veri(Z, 1))) = Val(Veri(X + 3, Y)) Then
                        Say = Say + 1
                        Liste(Say, 1) = Istasyon_Adi
                        Liste(Say, 2) = Istasyon_No
                        Liste(Say, 3) = DateSerial(Yil, Veri(X + 3, Y), Veri(Z, 1))
                        Liste(Say, 4) = Veri(Z, Y)
                    End If
                Next
            Next
        End If
    Next

    If Say > 0 Then
        Set S2 = Sheets.Add(, S1)
        S2.Name = "Analiz"
        S2.Range("A1").Resize(Say, 4) = Liste
        S2.Range("A1:D1").Font.Bold = True
        S2.Range("A1:D1").Font.ColorIndex = 3
        S2.Range("A1:D1").HorizontalAlignment = xlCenter
        S2.Range("A1").AutoFilter
        S2.Columns.AutoFit
       
        Veri = S2.Range("A2:B" & Say).Value
       
        For X = LBound(Veri) To UBound(Veri)
            Dizi.Item(Veri(X, 1) & "|" & Veri(X, 2)) = 1
        Next
   
        For Each Istasyon In Dizi.Keys
            Istasyon_No = Split(Istasyon, "|")(1)
            Istasyon_Adi = Split(Istasyon, "|")(0)
            S2.Range("A1").AutoFilter 1, Istasyon_Adi
            Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Sheets.Add , Sheets(Sheets.Count)
                If Len(Istasyon) > 31 Then
                    Sayfa_Adi = Replace(Replace(Left(Istasyon_Adi, 31 - Len(CStr(Istasyon_No)) - 1), "/", "-"), "|", "-") & "-" & Istasyon_No
                Else
                    Sayfa_Adi = Replace(Replace(Istasyon, "/", "-"), "|", "-")
                End If
                ActiveSheet.Name = Sayfa_Adi
                S2.Range("A1").CurrentRegion.Copy Range("A1")
                Range("A:B").Delete
                Range("A1").AutoFilter
                Cells.Columns.AutoFit
            End If
        Next
    End If
       
    On Error Resume Next
    S2.ShowAllData
    On Error GoTo 0
    S2.Select
       
    Set S1 = Nothing
    Set S2 = Nothing
       
    Application.ScreenUpdating = True

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

canigdeli · 17 Haziran 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

Olmayan yer varsa düzenleriz.

C++:

Option Explicit

Sub Analiz()
    Dim Dizi As Object, S1 As Worksheet, S2 As Worksheet, Sayfa As Worksheet, Veri As Variant
    Dim Son As Long, X As Long, Y As Integer, Say As Long, Metin As Variant, Istasyon As Variant
    Dim Yil As Integer, Tarih As Date, İstasyon_Adi As String, İstasyon_No As Long, Z As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("Report")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    On Error Resume Next
    Application.DisplayAlerts = False
        For Each Sayfa In ThisWorkbook.Worksheets
            If Sayfa.Name <> "Report" Then Sayfa.Delete
        Next
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son = 1 Then Son = 2
    Veri = S1.Range("B1:N" & Son).Value

    ReDim Liste(1 To S1.Rows.Count, 1 To 4)
    Say = 1
   
    Liste(Say, 1) = "İSTASYON ADI"
    Liste(Say, 2) = "İSTASYON NO"
    Liste(Say, 3) = "TARİH"
    Liste(Say, 4) = "GÜNLÜK ORTALAMA SICAKLIK"
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Left(Veri(X, 1), 3) = "Yıl" Then
            Yil = Mid(Veri(X, 1), 6, 4)
            Metin = Split(Veri(X, 1), ": ")
            Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            İstasyon_Adi = Metin
            If InStr(1, Metin, "/") > 0 Then
                Metin = Split(Veri(X, 1), "/")
                Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            End If
            İstasyon_No = Metin
            İstasyon_Adi = WorksheetFunction.Trim(Replace(İstasyon_Adi, "/" & Metin, ""))
            For Y = LBound(Veri, 2) + 1 To UBound(Veri, 2)
                For Z = X + 4 To X + 34
                    If Month(DateSerial(Yil, Veri(X + 3, Y), Veri(Z, 1))) = Val(Veri(X + 3, Y)) Then
'                    If Veri(Z, Y) <> Empty Then
                        Say = Say + 1
                        Liste(Say, 1) = İstasyon_Adi
                        Liste(Say, 2) = İstasyon_No
                        Liste(Say, 3) = DateSerial(Yil, Veri(X + 3, Y), Veri(Z, 1))
                        Liste(Say, 4) = Veri(Z, Y)
'                    End If
                    End If
                Next
            Next
        End If
    Next

    If Say > 0 Then
        Set S2 = Sheets.Add(, S1)
        S2.Name = "Analiz"
        S2.Range("A1").Resize(Say, 4) = Liste
        S2.Range("A1:D1").Font.Bold = True
        S2.Range("A1:D1").Font.ColorIndex = 3
        S2.Range("A1:D1").HorizontalAlignment = xlCenter
        S2.Range("A1").AutoFilter
        S2.Columns.AutoFit
       
        Veri = S2.Range("A2:A" & Say).Value
       
        For X = LBound(Veri) To UBound(Veri)
            Dizi.Item(Veri(X, 1)) = 1
        Next
   
        For Each Istasyon In Dizi.Keys
            S2.Range("A1").AutoFilter 1, Istasyon
            Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Sheets.Add , Sheets(Sheets.Count)
                ActiveSheet.Name = Replace(Left(Istasyon, 30), "/", "-")
                S2.Range("A1").CurrentRegion.Copy Range("A1")
                Range("A:B").Delete
                Range("A1").AutoFilter
                Cells.Columns.AutoFit
            End If
        Next
    End If
       
    On Error Resume Next
    S2.ShowAllData
    On Error GoTo 0
    S2.Select
       
    Set S1 = Nothing
    Set S2 = Nothing
       
    Application.ScreenUpdating = True

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

şimdilik tüm ricalarım gerçekleşti Korhan Bey.
Data üzerinde çalışmaya devam ettikçe farklı bir sorunla karşılaşırsam ( ki sanmıyorum tüm herşeyi hallettiniz) sizi rahatsız ederim.
Çok çok teşekkürler. Söylediğim gibi manuel olarak 5-6 ayda bitirebileceğim bir datayı yazdığınız kodlarla 1 güne indirdiniz.

canigdeli · 17 Haziran 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

Olmayan yer varsa düzenleriz.

C++:

Option Explicit

Sub Analiz()
    Dim Dizi As Object, S1 As Worksheet, S2 As Worksheet, Sayfa As Worksheet, Veri As Variant
    Dim Son As Long, X As Long, Y As Integer, Say As Long, Metin As Variant, Istasyon As Variant
    Dim Yil As Integer, Tarih As Date, İstasyon_Adi As String, İstasyon_No As Long, Z As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("Report")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    On Error Resume Next
    Application.DisplayAlerts = False
        For Each Sayfa In ThisWorkbook.Worksheets
            If Sayfa.Name <> "Report" Then Sayfa.Delete
        Next
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son = 1 Then Son = 2
    Veri = S1.Range("B1:N" & Son).Value

    ReDim Liste(1 To S1.Rows.Count, 1 To 4)
    Say = 1
   
    Liste(Say, 1) = "İSTASYON ADI"
    Liste(Say, 2) = "İSTASYON NO"
    Liste(Say, 3) = "TARİH"
    Liste(Say, 4) = "GÜNLÜK ORTALAMA SICAKLIK"
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Left(Veri(X, 1), 3) = "Yıl" Then
            Yil = Mid(Veri(X, 1), 6, 4)
            Metin = Split(Veri(X, 1), ": ")
            Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            İstasyon_Adi = Metin
            If InStr(1, Metin, "/") > 0 Then
                Metin = Split(Veri(X, 1), "/")
                Metin = WorksheetFunction.Trim(Metin(UBound(Metin)))
            End If
            İstasyon_No = Metin
            İstasyon_Adi = WorksheetFunction.Trim(Replace(İstasyon_Adi, "/" & Metin, ""))
            For Y = LBound(Veri, 2) + 1 To UBound(Veri, 2)
                For Z = X + 4 To X + 34
                    If Month(DateSerial(Yil, Veri(X + 3, Y), Veri(Z, 1))) = Val(Veri(X + 3, Y)) Then
'                    If Veri(Z, Y) <> Empty Then
                        Say = Say + 1
                        Liste(Say, 1) = İstasyon_Adi
                        Liste(Say, 2) = İstasyon_No
                        Liste(Say, 3) = DateSerial(Yil, Veri(X + 3, Y), Veri(Z, 1))
                        Liste(Say, 4) = Veri(Z, Y)
'                    End If
                    End If
                Next
            Next
        End If
    Next

    If Say > 0 Then
        Set S2 = Sheets.Add(, S1)
        S2.Name = "Analiz"
        S2.Range("A1").Resize(Say, 4) = Liste
        S2.Range("A1:D1").Font.Bold = True
        S2.Range("A1:D1").Font.ColorIndex = 3
        S2.Range("A1:D1").HorizontalAlignment = xlCenter
        S2.Range("A1").AutoFilter
        S2.Columns.AutoFit
       
        Veri = S2.Range("A2:A" & Say).Value
       
        For X = LBound(Veri) To UBound(Veri)
            Dizi.Item(Veri(X, 1)) = 1
        Next
   
        For Each Istasyon In Dizi.Keys
            S2.Range("A1").AutoFilter 1, Istasyon
            Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                Sheets.Add , Sheets(Sheets.Count)
                ActiveSheet.Name = Replace(Left(Istasyon, 30), "/", "-")
                S2.Range("A1").CurrentRegion.Copy Range("A1")
                Range("A:B").Delete
                Range("A1").AutoFilter
                Cells.Columns.AutoFit
            End If
        Next
    End If
       
    On Error Resume Next
    S2.ShowAllData
    On Error GoTo 0
    S2.Select
       
    Set S1 = Nothing
    Set S2 = Nothing
       
    Application.ScreenUpdating = True

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Soru sormaktan çok mahçup oluyorum ama data üzerinde çalıştıkça soru da oluşabiliyor o yüzden sizi böldüğüm için kusura bakmayın.

Sekme adını İstasyon ve Istasyon no şeklinde oluşturmak istersem aşağıdaki kısmı mı revize etmeliyim? Nasıl revize etmeliyim?

ActiveSheet.Name = Replace(Left(Istasyon, 30), "/", "-")

Sütunları alt alta sıralama hk yardım

canigdeli

YUSUF44

Destek Ekibi

canigdeli

YUSUF44

Destek Ekibi

canigdeli

YUSUF44

Destek Ekibi

canigdeli

YUSUF44

Destek Ekibi

canigdeli

YUSUF44

Destek Ekibi

Korhan Ayhan

Administrator

canigdeli

canigdeli

canigdeli

Korhan Ayhan

Administrator

canigdeli

YUSUF44

Destek Ekibi

Korhan Ayhan

Administrator

canigdeli

canigdeli