• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Tablo İsimlerinden Otomatik Alt Sayfa Oluşturma

  • Konbuyu başlatan Konbuyu başlatan progz
  • Başlangıç tarihi Başlangıç tarihi
P

progz

Katılım
12 Temmuz 2015
Mesajlar
9
Excel Vers. ve Dili
2010 eng
Merhabalar,

a ali 13 tr yes
b veli 24 tr no
z veli 44 tr no
c cem 65 en yes

Gibi bir tablom var yalnız 100 lerce tablo verisi mevcut. Benim istediğim 2 sutunda bulunan "ali,veli,cem" bu verileri okuyarak otomatik alt sayfa oluşturması. Oluşturduğu gibi verileride çekmesi lazım.

Veli İsminde sayfa oluşturduğunda içerik aşağıdaki gibi olmalıdır.

b veli 24 tr no
z veli 44 tr no


Artı olarak filtreleme yapıldığında gelen verileri tablo başlıkları ile kes dediğim zaman tablo başlığı ana sayfadan gidiyor. Heryeni alt sayfa açtığımda başlıklı halde gelmesi mümkünmüdür. Ben sadece verimi altına yapıştırayım.


Bu iş için sabahladım halen bitmiyor arkadaşlar. Yardımlarınız için çok teşekkür ederim şimdiden.
 
Forumda buna benzer sorular çözüldü.

Örnek dosya yüklerseniz daha hızlı yanıt alırsınız.

.
 
. . .

Tablo boyutunuz ve veriniz oldukça çok.

Bu aktarma işlemini gün içinde bir çok kez yapıyor musunuz. Yoksa bu tablo için bir kez mi aktarma işlemi olacak.

. . .
 
Bu tablo aktarma işlemi yalnızca bir kez olacak . Günlük herhangi bir işlem yapmıyorum.

Şimdi bir yandan manuel olarak devam ediyorum. Burada pratik öneriniz olabilirmi
 
. . .

Sorunuzda başlıklardan bahsetmişsiniz ama örnek dosyanızda başlık yok.

. . .
 
Plate Number - TVR - Date - Time - Alarm - Interval - Lane

başlıklar sırası ile böyle olacak.
Bu dosyanın eş benzeri 1 adet daha var üzerinde manuel işlem yapıyorum. Diğerine geçemediğim için daha başlığı koymayı unutmuşum.
 
. . .

Bendeki örnek başlıksız olduğu için bu şekilde hazırladım.
all vehicles 28 may sayfasında başlık satırını silip, KOD makrosunu çalıştırın.
İşlem uzun sürecektir, bitirmesini bekleyin.


Kod: 
Function SayfaVarMi(Sayfa As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(Sayfa).Name) > 0)
End Function


Sub Kod()
    
    Dim Sayfa As String
    Dim SA As Worksheet: Set SA = Sheets("all vehicles 28 may")
    
    Dim con As Object: Set con = CreateObject("adodb.connection")
    Dim rs As Object: Set rs = CreateObject("adodb.recordset")
    con.Open "Provider=Microsoft.Ace.Oledb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No"""
    
    Application.ScreenUpdating = False
    
    SA.Select
    Range("I:I").ClearContents
    Range("B1:B" & Rows.Count).Copy Range("I1")
    ActiveSheet.Range("$I$1:$I$" & Rows.Count).RemoveDuplicates Columns:=1, Header:=xlNo
    sonsatır = SA.Cells(Rows.Count, "A").End(3).Row
    
    For a = 1 To SA.Cells(Rows.Count, "I").End(3).Row
        
        Sayfa = SA.Cells(a, "I")
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add After:=SA
            ActiveSheet.Name = Sayfa
            Range("A1:F1") = Array("Plate Number", "TVR", "Date - Time", "Alarm", "Interval", "Lane")
        End If
        Sheets(Sayfa).Select
        
        sorgu = "Select [F1], [F2],[F3],[F4],[F5],[F6] From [all vehicles 28 may$] where [F2] = '" & SA.Cells(a, "I") & "'"
        rs.Open sorgu, con, 3, 1
        Range("A2").CopyFromRecordset rs
        rs.Close
        
        Cells.EntireColumn.AutoFit
        
    Next a
    
    SA.Select
    Range("I:I").ClearContents
    Set con = Nothing: Set rs = Nothing: sorgu = ""
    
    Application.ScreenUpdating = True
    MsgBox "B i t t i "
End Sub

. . .
 
Hocam kod çalıştı alt sayfalarıda oluşturdu ama sayfa boş , verileri çekmemiş
 
. . .

Bu tablonuzda başlıklar olduğu için kodlamada bazı değişiklikler oldu.
Kod içerisindeki sütun başlıkları, tablodaki başlıklar aynı olmalı.

Kodlarda kırmızı ile belirttiğim sayfa ismini değiştirerek diğer tablolarınızda da kullanabilirsiniz.


Kod: 
Function SayfaVarMi(Sayfa As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(Sayfa).Name) > 0)
End Function


Sub Kod()
    
    Dim Sayfa As String
    Dim SA As Worksheet: Set SA = Sheets("[B][COLOR="Red"]all vehicles 22 june[/COLOR][/B]")
    
    Dim con As Object: Set con = CreateObject("adodb.connection")
    Dim rs As Object: Set rs = CreateObject("adodb.recordset")
    con.Open "Provider=Microsoft.Ace.Oledb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=Yes"""
    
    Application.ScreenUpdating = False
    
    SA.Select
    Range("I:I").ClearContents
    Range("B1:B" & Rows.Count).Copy Range("I1")
    ActiveSheet.Range("$I$1:$I$" & Rows.Count).RemoveDuplicates Columns:=1, Header:=xlNo
    sonsatır = SA.Cells(Rows.Count, "A").End(3).Row
    
    For a = 2 To SA.Cells(Rows.Count, "I").End(3).Row
        
        Sayfa = SA.Cells(a, "I")
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add After:=SA
            ActiveSheet.Name = Sayfa
        End If
        Sheets(Sayfa).Select
        Range("A1:F1") = Array("Plate Number", "TVR", "Date - Time", "Alarm", "Interval", "Lane")
        
sorgu = "Select [B][Plate Number], [TVR], [Date - Time], [Alarm], [Interval], [Lane] [/B]From [" & SA.Name & "$] where [B][TVR] [/B]= '" & SA.Cells(a, "I") & "'"
        rs.Open sorgu, con, 3, 1
        Range("A2").CopyFromRecordset rs
        rs.Close
        
        Cells.EntireColumn.AutoFit
        
    Next a
    
    SA.Select
    Range("I:I").ClearContents
    Set con = Nothing: Set rs = Nothing: sorgu = ""
    
    Application.ScreenUpdating = True
    MsgBox "B i t t i "
End Sub

. . .
 
Hocam kod yine ilk baştaki kod gibi çalıştı sayfaları üretti ama içerik çekemedi.
 
. . .

Kodları yeni bir modüle açıp içine yapıştırıyorsunuz değil mi.

Bu kez siz kodları uyguladığınız tabloyu ekleyin. Hatalı kısmı inceleyelim.

. . .
 
Hüseyin hocam ilk gönderdiğiniz 28 olan dosya ile verileri değiştirip hallettim, sıkıntı gözükmüyor.
Sıkıntı olur mu ?
Daha sonra butonları kaldırıp teslim edeceğim.

Bu arada tekrardan teşekkür ederim herşey için elinize sağlık.
 
. . .

Tablo üzerindeki butonları silip,
farklı kaydetten excel çalışma kitabı (*.xlsx) olarak kaydederseniz
makro kodlarını, uyarı verdikten sonra kendisi silecektir.

. . .
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst