Soru Sayfadaki Birden Fazla Veriyi Yan Sayfaya Listeleme

[RBozkurt]

İyi günler.
Hayali veriler ile oluşturduğum bir excel çalışma kitabı ekliyorum. İçerisinde 2 sayfa bulunmaktadır.

Burda istenilen;
TapuRapor sayfasındaki verileri Sonuc sayfasına sıralamaktır. Eklenecek verileri yeşil ile renklendirme yaptım.
Karşımıza şöyle bir problem çıkıyor. Her kişiye ait satırlardaki aralıklar aynı değil.
Araya 1 kişiye ait beyan şerh girince alt alta 1, 5 veya yeri geliyor 25 satır kayıyor. Örnek olarak bıraktım (Satır 52)

Bu konuda yardımcı olabilirmisiniz?

Örnek Dosya:   https://dosya.co/508xes6dztzd/Örnek_Rapor.xlsx.html

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz:

Sub tapu()
Set s1 = Sheets("TapuRapor")
Set s2 = Sheets("Sonuc")
son = s1.Cells(Rows.Count, "R").End(3).Row

For hisse = 1 To son
    If s1.Cells(hisse, "R") = "Hisse" Then
        yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
        s2.Cells(yeni, "A") = yeni - 1
        s2.Cells(yeni, "B") = s1.[C4]
        s2.Cells(yeni, "C") = s1.[H2]
        s2.Cells(yeni, "D") = s1.[M2]
        s2.Cells(yeni, "E") = s1.Cells(hisse + 4, "D")
        s2.Cells(yeni, "F") = s1.Cells(hisse + 4, "G")
        s2.Cells(yeni, "G") = s1.Cells(hisse + 1, "R")
        s2.Cells(yeni, "H") = s1.[M3]
        s2.Cells(yeni, "I") = s1.[M4]
        s2.Cells(yeni, "J") = s1.Cells(hisse + 4, "J")
        s2.Cells(yeni, "K") = s1.Cells(hisse + 4, "N")
        s2.Cells(yeni, "L") = s1.Cells(hisse + 4, "A")
    End If
Next
End Sub

 

[RBozkurt]

@YUSUF44 elinize sağlık tek kelime ile mükemmel çalışıyor.

Orj veride il/ilçe ve ada/parsel birleşik. Bunu "/" baz alarak manuel şekilde bölmek gerekiyor.
Bu makro içerisine bunuda eklenebilir mi?

Sonuc sayfasında B ve C , E ve F sütunları güncelledim.

2. Örnek Veri:   https://dosya.co/1sf07v5davx1/Örnek_Rapor.xlsx.html

 

[YUSUF44]

Aşağıdaki gibi deneyin:

Sub tapu()
Set s1 = Sheets("TapuRapor")
Set s2 = Sheets("Sonuc")
son = s1.Cells(Rows.Count, "R").End(3).Row

For hisse = 1 To son
    If s1.Cells(hisse, "R") = "Hisse" Then
        yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
        s2.Cells(yeni, "A") = yeni - 1
        s2.Cells(yeni, "B") = Trim(Left(s1.[C4], WorksheetFunction.Find("/", s1.[C4]) - 1))
        s2.Cells(yeni, "C") = Trim(Right(s1.[C4], Len(s1.[C4]) - WorksheetFunction.Find("/", s1.[C4])))
        s2.Cells(yeni, "D") = s1.[H2]
        s2.Cells(yeni, "E") = Trim(Left(s1.[M2], WorksheetFunction.Find("/", s1.[M2]) - 1))
        s2.Cells(yeni, "F") = Trim(Right(s1.[M2], Len(s1.[M2]) - WorksheetFunction.Find("/", s1.[M2])))
        s2.Cells(yeni, "G") = s1.Cells(hisse + 4, "D")
        s2.Cells(yeni, "H") = s1.Cells(hisse + 4, "G")
        s2.Cells(yeni, "I") = s1.Cells(hisse + 1, "R")
        s2.Cells(yeni, "J") = s1.[M3]
        s2.Cells(yeni, "K") = s1.[M4]
        s2.Cells(yeni, "L") = s1.Cells(hisse + 4, "J")
        s2.Cells(yeni, "M") = s1.Cells(hisse + 4, "N")
        s2.Cells(yeni, "N") = s1.Cells(hisse + 4, "A")
    End If
Next
End Sub

 

[RBozkurt]

@YUSUF44 çok teşekkürler. Bu makroda eksiksiz çalışıyor. Denedim problem yok.
Bu makro ile alttaki makroyu birleştirerek sayfaya buton şeklinde ekleyeceğim.

Satır 4 de: Const WBPath = "C:\Users\KULLANICIADI\Desktop\" kullanıcı adı kısmı vererek belirtilen klasöre sayfaları ayırıp aynı isimde masaüzerine kaydediyor.
Bu satırı olduğu için her bilgisayarda çalışmaz.

Bu makroyu çalışma kitabının bulunduğu klasör içine ayırarak kaydetmesi mümkünmüdür?

Sub Sayfaları_Ayır_ve_Kaydet()
Dim sht As Worksheet
Dim NFName As String
Const WBPath = "C:\Users\KULLANICIADI\Desktop\"
For Each sht In ActiveWorkbook.Worksheets
sht.Copy
sht.Cells.Copy
Range("A1").PasteSpecial (xlPasteValuesAndNumberFormats)
Range("A1").Select
Application.CutCopyMode = False
NFName = WBPath & sht.Name & ".xls"
ActiveWorkbook.SaveAs Filename:=NFName, _
FileFormat:=xlNormal, CreateBackup:=False
ActiveWindow.Close
Next
End Sub

 

[RBozkurt]

Bu mesajdaki makroda çalışma kitabındaki TapuRapor verisini;

Kitabın başına ANASAYFA şeklinde bir açıklama sayfası ekleyip
İşlem yapılacak dosyayı seçin gibi Gözat/Browse şeklinde bu veriyi excel içine aldırıp aynı şekilde de çalıştırılabilinirmi?

Elimizde ilk veri TapuRapor olarak var. Diğer kısımlar sonradan ekledim.
Ben sorgu yapıp TapuRaporu indiriyorum. Bunu açıp kopyalayıp diğer makrolu excele atıp makroları çalıştırmam gerekiyor yani.

 

[RBozkurt]

Mesaj düzenleme süresi olduğu için düzeltemedim.

Örnek:  https://dosya.co/35nks8tspwn0/Tapu.xlsm.html

Alttaki makroyu buldum. Orada hücre alalığı ayarlamışlar. Buna benzer işlem yapacaktır.
Seçilen excel dosyasını TapuRapor sayfasına koyacak şekilde.

Dim dosya As String
Sub dosya_sec()
    dosya = Application.GetOpenFilename("dosya Seçiniz (*.xls;*.xlsx;*.xlm;*.xlsm),*.xls;*.xlsx;*.xlm;*.xlsm")
    If dosya <> "False" Then
        MsgBox "işlem tamam"
    Else
        MsgBox "dosya seçmediniz"
    End If
  
End Sub

Sub veri_al()
If dosya <> "" Then
        On Error GoTo hata
           Application.ScreenUpdating = False
               Set kaynak = Workbooks.Open(dosya, True, True)
    kaynak.Worksheets("sayfa1").Range("E10:L41").Copy ThisWorkbook.Sheets("anasayfa").Range("e10")
           kaynak.Close False
           Set kaynak = Nothing
          
hata:
          
           Application.ScreenUpdating = True
Else
     MsgBox "dosya seçili değil"
End If
End Sub

 

[RBozkurt]

Dosya seçme ve Verileri alma makrosunu alta ekliyorum. Problemsiz çalışıyor.
Sadece ayırıp bulunduğu klasöre kayıt makrosu kaldı.

Dim Dosya As String
Sub Tapu_Kaydı_Sec()
    Dosya = Application.GetOpenFilename("Tapu Kaydı Seçin (*.xls;*.xlsx;*.xlm;*.xlsm),*.xls;*.xlsx;*.xlm;*.xlsm")
    If Dosya <> "False" Then
        MsgBox "Tapu Kaydı seçildi."
    Else
        MsgBox "Dosya Seçmediniz!"
    End If
  
End Sub
Sub Verileri_Al()
If Dosya <> "" Then
        On Error GoTo hata
           Application.ScreenUpdating = False
               Set kaynak = Workbooks.Open(Dosya, True, True)
    kaynak.Worksheets("TapuRapor").Range("A:U").Copy ThisWorkbook.Sheets("TapuRapor").Range("A1")
           kaynak.Close False
           Set kaynak = Nothing
          
hata:
          
           Application.ScreenUpdating = True
Else
     MsgBox "Dosya Seçili Değil!.."
End If
End Sub

 

[RBozkurt]

Tüm sayfaları masaüzerine kaydeder.

Sub Sayfalara_Ayir()
Application.DisplayAlerts = False
Dim sayfa As Worksheet, kitap As Workbook
For Each sayfa In ThisWorkbook.Sheets
If sayfa.Name <> "Genel" Then
Set kitap = Workbooks.Add
sayfa.Copy kitap.Sheets(1)
kitap.SaveAs ThisWorkbook.Path & "\" & sayfa.Name & ".xls", xlExcel8
kitap.Close False
End If
Next sayfa
Set sayfa = Nothing
Application.DisplayAlerts = True
MsgBox "İşlem Tamamlandı.", vbInformation, "BİLGİ"
End Sub