• DİKKAT

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

Yeni Sayfa

S

sedat2161

Katılım
1 Ekim 2017
Mesajlar
694
Excel Vers. ve Dili
2019 türkçe
Merhaba iyi çalışmalar arkadaşlar. Ekte gönderdiğim dosyada sayfalara aktar butonununa tıkladığımda A sütunundaki bilgiler doğrultusunda yeni sayfalar açılıyor. Benim isteğim aynı butonda a sütunu değilde d ve f sütunundaki bilgiler doğrultusunda yeni sayfalar açılsın . Yardımcı olursanız çok sevinirim.
 

Ekli dosyalar

Merhaba.
Ekteki dosyayı inceleyin.

"Sayfalara Aktar" düğmesini tıklatınca size kolon harfini soracak siz hangi kolon harfini yazarsanız işlemi o kolona göre yapacaktır.
 

Ekli dosyalar

İyi çalışmalar F sutununda bazı hücreler boş olacağından diğer bilgilerin aktarılması gerekiyor. F sutunununu aktardığımda sorun veriyor. Örnek dosya ekte sunulmuştur. Şimdiden ilgilenecek arkadaşlara teşekkür ederim.
 

Ekli dosyalar

Eğer F sütunu boşsa hangi sayfaya aktarılacak.
 
If Not SayfaVarmi(Bak.Value) Then

Satırını aşağıdaki ile değiştirin.

If Not SayfaVarmi(Bak.Value) And Not Bak.Value = Empty Then
 
sedat2161' Alıntı:
Çok sağolun. Emeğinize sağlık. Hayırlı akşamlar
Genişletmek için tıkla ...
Hayırlı sabahlar. İyi çalışmalar arkadaşlar. Gönderdiğiniz kodu denedim. F sutununda boş olanlar yine dolu olan bilginin altına ekleniyor. Aktar butonuna bastıktan sonra açılan yeni sayfalar örenek dosyası ekte sunulmuştur. Birde hücre genişliği ana sayfa ile aynı olma imkanı varmı.İlgilenirseniz çok memenun olurum .
 

Ekli dosyalar

Sub SayfalaraAktar() başlıklı kodu

Aşağıdakiler ile değiştirin.

Kod: 
Sub SayfalaraAktar()
    Dim syfTumu As Worksheet
    Dim syfYeni As Worksheet
    Dim Bak As Range
    Dim SatirYeni As Long
    Dim SatirTümü As Long
    Dim Sutun As String
    
    Sutun = InputBox("Kolon harfini giriniz.")
    SatirTümü = Cells(Rows.Count, Sutun).End(3).Row
    Set syfTumu = Worksheets("Tumu")
    For Each Bak In syfTumu.Range(Sutun & "2:" & Sutun & SatirTümü)
        If Not Bak.Value = Empty Then
            If Not SayfaVarmi(Bak.Value) Then
            
                Set syfYeni = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(Worksheets.Count))
                syfYeni.Name = Bak.Value
                syfTumu.Range("A1:F1").Copy syfYeni.Range("A1")
                syfTumu.Range("M1").Copy syfYeni.Range("G1")
            End If
            SatirYeni = Cells(Rows.Count, Sutun).End(3).Row + 1
            syfTumu.Range(Range("A" & Bak.Row).Address & ":" & Range("F" & Bak.Row).Address).Copy syfYeni.Range("A" & SatirYeni)
            syfTumu.Range(Range("M" & Bak.Row).Address).Copy syfYeni.Range("G" & SatirYeni)
        End If
    Next
    syfTumu.Activate
End Sub
 
dalgalikur' Alıntı:
Sub SayfalaraAktar() başlıklı kodu

Aşağıdakiler ile değiştirin.

Kod: 
Sub SayfalaraAktar()
    Dim syfTumu As Worksheet
    Dim syfYeni As Worksheet
    Dim Bak As Range
    Dim SatirYeni As Long
    Dim SatirTümü As Long
    Dim Sutun As String
   
    Sutun = InputBox("Kolon harfini giriniz.")
    SatirTümü = Cells(Rows.Count, Sutun).End(3).Row
    Set syfTumu = Worksheets("Tumu")
    For Each Bak In syfTumu.Range(Sutun & "2:" & Sutun & SatirTümü)
        If Not Bak.Value = Empty Then
            If Not SayfaVarmi(Bak.Value) Then
           
                Set syfYeni = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(Worksheets.Count))
                syfYeni.Name = Bak.Value
                syfTumu.Range("A1:F1").Copy syfYeni.Range("A1")
                syfTumu.Range("M1").Copy syfYeni.Range("G1")
            End If
            SatirYeni = Cells(Rows.Count, Sutun).End(3).Row + 1
            syfTumu.Range(Range("A" & Bak.Row).Address & ":" & Range("F" & Bak.Row).Address).Copy syfYeni.Range("A" & SatirYeni)
            syfTumu.Range(Range("M" & Bak.Row).Address).Copy syfYeni.Range("G" & SatirYeni)
        End If
    Next
    syfTumu.Activate
End Sub
Genişletmek için tıkla ...
İyi çalışmalar çok rahatsızlık verdim kusura bakmayın ama bir türlü kodlar olmadı. f sutununda sorun var. Örneği 3 tane 1 var iki tane geliyor. 4 karışık geldi. Örnek dosyayı ekte gönderiyorum. sizi zahmet benim için çok önemli. İyi çalışmalar
 

Ekli dosyalar

  • 25.xls
    25.xls
    59 KB · Görüntüleme: 7
Bütün kodları silin aşağıdakileri kopyalayın.

Kod: 
    Dim syfYeni As Worksheet
    
Sub SayfalaraAktar()
    Dim syfTumu As Worksheet
    Dim Bak As Range
    Dim SatirYeni As Long
    Dim SatirTümü As Long
    Dim Sutun As String
    
    Sutun = InputBox("Kolon harfini giriniz.")
    SatirTümü = Cells(Rows.Count, Sutun).End(3).Row
    Set syfTumu = Worksheets("Tumu")
    For Each Bak In syfTumu.Range(Sutun & "2:" & Sutun & SatirTümü)
        If Not Bak.Value = Empty Then
            If Not SayfaVarmi(Bak.Value) Then
                Set syfYeni = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(Worksheets.Count))
                syfYeni.Name = Bak.Value
                syfTumu.Range("A1:F1").Copy syfYeni.Range("A1")
                syfTumu.Range("A1:F1").Copy
                syfYeni.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
                syfTumu.Range("M1").Copy syfYeni.Range("G1")
            End If
            SatirYeni = syfYeni.Cells(Rows.Count, Sutun).End(3).Row + 1
            syfTumu.Range(Range("A" & Bak.Row).Address & ":" & Range("F" & Bak.Row).Address).Copy syfYeni.Range("A" & SatirYeni)
            syfTumu.Range(Range("M" & Bak.Row).Address).Copy syfYeni.Range("G" & SatirYeni)
        End If
    Next
    syfTumu.Activate
End Sub

Function SayfaVarmi(ad As String) As Boolean
    Dim syf As Worksheet
    For Each Bak In ThisWorkbook.Worksheets
        If Bak.Name = ad Then
            SayfaVarmi = True
            Set syfYeni = Bak
            Exit Function
        End If
    Next
    SayfaVarmi = False
End Function

Sub SayfalariSil()
    Application.DisplayAlerts = False
    While Worksheets.Count > 1
        Sheets(2).Delete
    Wend
    Application.DisplayAlerts = True
End Sub
 
dalgalikur' Alıntı:
Bütün kodları silin aşağıdakileri kopyalayın.

Kod: 
    Dim syfYeni As Worksheet
   
Sub SayfalaraAktar()
    Dim syfTumu As Worksheet
    Dim Bak As Range
    Dim SatirYeni As Long
    Dim SatirTümü As Long
    Dim Sutun As String
   
    Sutun = InputBox("Kolon harfini giriniz.")
    SatirTümü = Cells(Rows.Count, Sutun).End(3).Row
    Set syfTumu = Worksheets("Tumu")
    For Each Bak In syfTumu.Range(Sutun & "2:" & Sutun & SatirTümü)
        If Not Bak.Value = Empty Then
            If Not SayfaVarmi(Bak.Value) Then
                Set syfYeni = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(Worksheets.Count))
                syfYeni.Name = Bak.Value
                syfTumu.Range("A1:F1").Copy syfYeni.Range("A1")
                syfTumu.Range("A1:F1").Copy
                syfYeni.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
                syfTumu.Range("M1").Copy syfYeni.Range("G1")
            End If
            SatirYeni = syfYeni.Cells(Rows.Count, Sutun).End(3).Row + 1
            syfTumu.Range(Range("A" & Bak.Row).Address & ":" & Range("F" & Bak.Row).Address).Copy syfYeni.Range("A" & SatirYeni)
            syfTumu.Range(Range("M" & Bak.Row).Address).Copy syfYeni.Range("G" & SatirYeni)
        End If
    Next
    syfTumu.Activate
End Sub

Function SayfaVarmi(ad As String) As Boolean
    Dim syf As Worksheet
    For Each Bak In ThisWorkbook.Worksheets
        If Bak.Name = ad Then
            SayfaVarmi = True
            Set syfYeni = Bak
            Exit Function
        End If
    Next
    SayfaVarmi = False
End Function

Sub SayfalariSil()
    Application.DisplayAlerts = False
    While Worksheets.Count > 1
        Sheets(2).Delete
    Wend
    Application.DisplayAlerts = True
End Sub
Genişletmek için tıkla ...
Çok sağolun emeğinize sağlık, süper oldu. İyi çalışmalar diliyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst