Yeni Sayfa

[sedat2161]

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.

 

[Muzaffer Ali]

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.

 

[muygun]

Merhaba;
Alternatif olsun.
Eki deneyin.
İyi çalışmalar.

 

[sedat2161]

Çok teşekkür ederim ilginiz için iyi çalışmalar.

 

[sedat2161]

İ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.

 

[Muzaffer Ali]

Eğer F sütunu boşsa hangi sayfaya aktarılacak.

 

[sedat2161]

F

Eğer F sütunu boşsa hangi sayfaya aktarılacak.

Sutununda dolu olanlar aktarılacak

 

[Muzaffer Ali]

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]

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

Çok sağolun. Emeğinize sağlık. Hayırlı akşamlar

 

[sedat2161]

Çok sağolun. Emeğinize sağlık. Hayırlı akşamlar

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 .

 

[Muzaffer Ali]

Sub SayfalaraAktar() başlıklı kodu

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

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

 

[sedat2161]

Sub SayfalaraAktar() başlıklı kodu

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

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

İ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

 

[Muzaffer Ali]

Bütün kodları silin aşağıdakileri kopyalayın.

    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

 

[sedat2161]

Bütün kodları silin aşağıdakileri kopyalayın.

    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

Çok sağolun emeğinize sağlık, süper oldu. İyi çalışmalar diliyorum.