Yeni müşteri sayfası oluşturma makrosu

[mehmetsgk]

merhaba arkadaşlar aşağıda açıkladığım gibi makroya ihtiyacım var yardımcı olursanız çok sevinirim.
işlem: LİST İSİMLİ SAYFAYA BİR BUTON YAPTIM BUTONA BASILDIĞINDA MUSTERİ İSİMLİ SAYFANIN BİR KOPYASINI OLUŞTURUCAK BU KOPYA SAYFAYA LİST İSİMLİ SAYFANIN B1 HÜCERİNDEKİ METİNİ SAYFA İSİM OLARAK VERİCEK. LİST İSİMLİ SAYFAYANIN 4.SATIRINA YENİ SATIR EKLEYİP A4 HÜCRESİNE B1 HÜCRESİNDEKİ METNİ YAZICAK VE YENİ OLUŞTURDUĞUMUZ VE İSİMİNİ DEĞİŞTİRDİĞİMİZ SAYFANIN KÖPRÜSÜNÜ ATAYACAĞIZ.

https://s6.dosya.tc/server22/rswjx0/MELIH_YENI_PROJE__1_.xlsm.html

 

[pitchoute]

Merhaba, deneyip sonucu paylaşabilir misiniz;

Sub YeniSayfaOlustur()
    Dim musteriSayfasi As Worksheet
    Dim listSayfasi As Worksheet
    Dim yeniSayfaAdi As String
    Dim sayfaVar As Boolean
    

    On Error Resume Next
    Set listSayfasi = ThisWorkbook.Worksheets("LİST")
    Set musteriSayfasi = ThisWorkbook.Worksheets("MUSTERİ")
    On Error GoTo 0
    If listSayfasi Is Nothing Then
        MsgBox "LİST adlı sayfa bulunamadı!", vbExclamation
        Exit Sub
    End If
    If musteriSayfasi Is Nothing Then
        MsgBox "MUSTERİ adlı sayfa bulunamadı!", vbExclamation
        Exit Sub
    End If
    yeniSayfaAdi = Trim(listSayfasi.Range("B1").Value)
    If yeniSayfaAdi = "" Then
        MsgBox "LİST sayfasındaki B1 hücresi boş!", vbExclamation
        Exit Sub
    End If
    sayfaVar = False
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name = yeniSayfaAdi Then
            sayfaVar = True
            Exit For
        End If
    Next ws
    If sayfaVar Then
        MsgBox "'" & yeniSayfaAdi & "' adında bir sayfa zaten var!", vbExclamation
        Exit Sub
    End If
    musteriSayfasi.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    ActiveSheet.Name = yeniSayfaAdi
    listSayfasi.Rows("4:4").Insert Shift:=xlDown
    listSayfasi.Range("A4").Value = yeniSayfaAdi
    listSayfasi.Hyperlinks.Add Anchor:=listSayfasi.Range("A4"), Address:="", SubAddress:="'" & yeniSayfaAdi & "'!A1"
    MsgBox "'" & yeniSayfaAdi & "' adlı yeni sayfa başarıyla oluşturuldu!", vbInformation
End Sub

 

[mehmetsgk]

Merhaba, deneyip sonucu paylaşabilir misiniz;

Sub YeniSayfaOlustur()
    Dim musteriSayfasi As Worksheet
    Dim listSayfasi As Worksheet
    Dim yeniSayfaAdi As String
    Dim sayfaVar As Boolean
   

    On Error Resume Next
    Set listSayfasi = ThisWorkbook.Worksheets("LİST")
    Set musteriSayfasi = ThisWorkbook.Worksheets("MUSTERİ")
    On Error GoTo 0
    If listSayfasi Is Nothing Then
        MsgBox "LİST adlı sayfa bulunamadı!", vbExclamation
        Exit Sub
    End If
    If musteriSayfasi Is Nothing Then
        MsgBox "MUSTERİ adlı sayfa bulunamadı!", vbExclamation
        Exit Sub
    End If
    yeniSayfaAdi = Trim(listSayfasi.Range("B1").Value)
    If yeniSayfaAdi = "" Then
        MsgBox "LİST sayfasındaki B1 hücresi boş!", vbExclamation
        Exit Sub
    End If
    sayfaVar = False
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name = yeniSayfaAdi Then
            sayfaVar = True
            Exit For
        End If
    Next ws
    If sayfaVar Then
        MsgBox "'" & yeniSayfaAdi & "' adında bir sayfa zaten var!", vbExclamation
        Exit Sub
    End If
    musteriSayfasi.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    ActiveSheet.Name = yeniSayfaAdi
    listSayfasi.Rows("4:4").Insert Shift:=xlDown
    listSayfasi.Range("A4").Value = yeniSayfaAdi
    listSayfasi.Hyperlinks.Add Anchor:=listSayfasi.Range("A4"), Address:="", SubAddress:="'" & yeniSayfaAdi & "'!A1"
    MsgBox "'" & yeniSayfaAdi & "' adlı yeni sayfa başarıyla oluşturuldu!", vbInformation
End Sub

üstadım harika olmuş uyarıları mesajlarını eklemeniz süper olmuş .sadece eklemeyi unutum bir kısım var oda şu; yeni kopya sayfadaki a1 hücresine "liste sayfası b2 hücresindeki" metin yazacak ve kopya sayfadaki d1 hücresindeki borc tutarı list sayfadaki b4 hücresinden veri çekecek. özetle= butona basılınca yeni müşteri sayfası oluşacak bu sayfaya müşteri ismi verilecek list sayfasaına yeni müşteri eklenecek,koprü oluşacak ve borçunu bu sayfaya çekecek.

 

[pitchoute]

Beğenmiş olmanıza sevindim. Belirtmiş olduklarınızı anladığım kadarıyla eklemeye çalıştım, eksik nokta olursa belirtebilirsiniz. İyi çalışmalar;

Sub YeniSayfaOlustur()
    Dim musteriSayfasi As Worksheet
    Dim listSayfasi As Worksheet
    Dim yeniSayfa As Worksheet
    Dim yeniSayfaAdi As String
    Dim sayfaVar As Boolean
  
    On Error Resume Next
    Set listSayfasi = ThisWorkbook.Worksheets("LİST")
    Set musteriSayfasi = ThisWorkbook.Worksheets("MUSTERİ")
    On Error GoTo 0
    
    If listSayfasi Is Nothing Then
        MsgBox "LİST adlı sayfa bulunamadı!", vbExclamation
        Exit Sub
    End If
    
    If musteriSayfasi Is Nothing Then
        MsgBox "MUSTERİ adlı sayfa bulunamadı!", vbExclamation
        Exit Sub
    End If
    
    yeniSayfaAdi = Trim(listSayfasi.Range("B1").Value)
    If yeniSayfaAdi = "" Then
        MsgBox "LİST sayfasındaki B1 hücresi boş!", vbExclamation
        Exit Sub
    End If
    
    sayfaVar = False
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name = yeniSayfaAdi Then
            sayfaVar = True
            Exit For
        End If
    Next ws
    
    If sayfaVar Then
        MsgBox "'" & yeniSayfaAdi & "' adında bir sayfa zaten var!", vbExclamation
        Exit Sub
    End If
    
    musteriSayfasi.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    ActiveSheet.Name = yeniSayfaAdi
    Set yeniSayfa = ActiveSheet
    
    yeniSayfa.Range("A1").Value = listSayfasi.Range("B2").Value
    yeniSayfa.Range("D1").Formula = "=LİST!B4"
    listSayfasi.Rows("4:4").Insert Shift:=xlDown
    listSayfasi.Range("A4").Value = yeniSayfaAdi
    listSayfasi.Hyperlinks.Add Anchor:=listSayfasi.Range("A4"), Address:="", SubAddress:="'" & yeniSayfaAdi & "'!A1"
    
    MsgBox "'" & yeniSayfaAdi & "' adlı yeni sayfa başarıyla oluşturuldu!", vbInformation
End Sub

 

[mehmetsgk]

Beğenmiş olmanıza sevindim. Belirtmiş olduklarınızı anladığım kadarıyla eklemeye çalıştım, eksik nokta olursa belirtebilirsiniz. İyi çalışmalar;

Sub YeniSayfaOlustur()
    Dim musteriSayfasi As Worksheet
    Dim listSayfasi As Worksheet
    Dim yeniSayfa As Worksheet
    Dim yeniSayfaAdi As String
    Dim sayfaVar As Boolean

    On Error Resume Next
    Set listSayfasi = ThisWorkbook.Worksheets("LİST")
    Set musteriSayfasi = ThisWorkbook.Worksheets("MUSTERİ")
    On Error GoTo 0
  
    If listSayfasi Is Nothing Then
        MsgBox "LİST adlı sayfa bulunamadı!", vbExclamation
        Exit Sub
    End If
  
    If musteriSayfasi Is Nothing Then
        MsgBox "MUSTERİ adlı sayfa bulunamadı!", vbExclamation
        Exit Sub
    End If
  
    yeniSayfaAdi = Trim(listSayfasi.Range("B1").Value)
    If yeniSayfaAdi = "" Then
        MsgBox "LİST sayfasındaki B1 hücresi boş!", vbExclamation
        Exit Sub
    End If
  
    sayfaVar = False
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name = yeniSayfaAdi Then
            sayfaVar = True
            Exit For
        End If
    Next ws
  
    If sayfaVar Then
        MsgBox "'" & yeniSayfaAdi & "' adında bir sayfa zaten var!", vbExclamation
        Exit Sub
    End If
  
    musteriSayfasi.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    ActiveSheet.Name = yeniSayfaAdi
    Set yeniSayfa = ActiveSheet
  
    yeniSayfa.Range("A1").Value = listSayfasi.Range("B2").Value
    yeniSayfa.Range("D1").Formula = "=LİST!B4"
    listSayfasi.Rows("4:4").Insert Shift:=xlDown
    listSayfasi.Range("A4").Value = yeniSayfaAdi
    listSayfasi.Hyperlinks.Add Anchor:=listSayfasi.Range("A4"), Address:="", SubAddress:="'" & yeniSayfaAdi & "'!A1"
  
    MsgBox "'" & yeniSayfaAdi & "' adlı yeni sayfa başarıyla oluşturuldu!", vbInformation
End Sub

üstadım hata veriyor. kopya sayfanın d1 hücresini alıp list sayfası b4 e kopyalaması lazım ken, formul : kopya sayfadaki formüllerin tümünü (c3 , d3 ve d1 formülleri) değerlerini siliyor ve list b4 e herhangi bir değer taşımıyor.