Farklı Kitaptan Ara Bul Listele

1

1mak1mak

Katılım
9 Ocak 2011
Mesajlar
354
Excel Vers. ve Dili
2007 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2023
Merhaba
Aynı klasördeki Farklı bir kitap ile diğer bir kitaptaki sayfalardan açıklaması ile değişken verileri isteğe göre çekmek istiyorum.
Örnek olarak verileri çekeceğim Kriterde Daire No sunu A1 hücresine girdiğimde (D10 şeklinde) Daire nosunun tablolardaki TL cinsinden değerleri
srasına göre alt alta listelemesini istiyorum 2 ad Buton olacak Butonun bir tanesi Doğalgaz sayfasından 2 Buton Klima Sayfasındaki
verileri alt alta listeleyecek Örnek olarak Rapor dosyasına elle girdiğim şekilde. Veri dosyası ve Örnek Rapor dosyası ektedir.
Yardımcı olabilecek ustalara şimdiden çok teşekkür ederim.
 

Ekli dosyalar

1

1mak1mak

Katılım
9 Ocak 2011
Mesajlar
354
Excel Vers. ve Dili
2007 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2023
Bakanlar olmuş ama hocaların gözünden kaçtı herhalde desteğinizi bekliyorum anlaşılmayan birşey varsa söylerseniz yazarım.
iyi akşamlar
 
1

1mak1mak

Katılım
9 Ocak 2011
Mesajlar
354
Excel Vers. ve Dili
2007 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2023
Anladımki destek istediğim sorumun cevabı yok VBA yerine listelemeyi elle yapacaz.
Bir daha soru sorarken önceden teşekkür etmemek lazımmış kimse ilgilenmedi.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,269
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

Boş bir modüle aşağıdaki kodu uygulayınız.

C++: 
Option Explicit

Sub Dogalgaz_Borc_Raporu()
    Dim Yol As String, Dosya As String, WB1 As Workbook, WB2 As Workbook
    Dim WS1 As Worksheet, WS2 As Worksheet, Apartment_No As Range
    Dim Find_Data As Range, First_Address As String, Satir As Long
    
    Application.ScreenUpdating = False
    
    Set WB1 = ThisWorkbook
    Set WS1 = WB1.Sheets("Sayfa1")
    
    WS1.Range("A2:B" & WS1.Rows.Count).Clear
    Satir = 2
    
    Yol = WB1.Path & Application.PathSeparator
    Dosya = Yol & "Borç Listesi.xlsx"
    
    Set WB2 = Workbooks.Open(Dosya, False, False)
    Set WS2 = WB2.Sheets("D.Gaz1")
    
    Set Apartment_No = WS2.Range("A:A").Find(WS1.Range("A1"), , , xlWhole)
    
    If Not Apartment_No Is Nothing Then
        Set Find_Data = WS2.Rows(3).Find("Doğalgaz Borç", , , xlPart)
        If Not Find_Data Is Nothing Then
            First_Address = Find_Data.Address
            Do
                WS1.Cells(Satir, 1) = Find_Data.Value
                WS1.Cells(Satir, 2) = WS2.Cells(Apartment_No.Row, Find_Data.Column).Value
                Satir = Satir + 1
                Set Find_Data = WS2.Rows(3).FindNext(Find_Data)
            Loop While Not Find_Data Is Nothing And Find_Data.Address <> First_Address
        End If
        
        WS1.Range("B2:B" & Satir).Style = "Currency"
        WS1.Columns("A:B").AutoFit
        
        WB2.Close False
        Application.ScreenUpdating = True
        
        MsgBox WS1.Range("A1") & " numaralı daireye ait borç listesi hazırlanmıştır.", vbInformation
    Else
        WB2.Close False
        Application.ScreenUpdating = True
        
        MsgBox WS1.Range("A1") & " numaralı daire bulunamadı!", vbCritical
    End If
    
    Set Apartment_No = Nothing
    Set Find_Data = Nothing
    Set WB1 = Nothing
    Set WS1 = Nothing
    Set WB2 = Nothing
    Set WS2 = Nothing
End Sub

Sub Klima_Borc_Raporu()
    Dim Yol As String, Dosya As String, WB1 As Workbook, WB2 As Workbook
    Dim WS1 As Worksheet, WS2 As Worksheet, Apartment_No As Range
    Dim Find_Data As Range, First_Address As String, Satir As Long
    
    Application.ScreenUpdating = False
    
    Set WB1 = ThisWorkbook
    Set WS1 = WB1.Sheets("Sayfa1")
    
    WS1.Range("A2:B" & WS1.Rows.Count).Clear
    Satir = 2
    
    Yol = WB1.Path & Application.PathSeparator
    Dosya = Yol & "Borç Listesi.xlsx"
    
    Set WB2 = Workbooks.Open(Dosya, False, False)
    Set WS2 = WB2.Sheets("Klima")
    
    Set Apartment_No = WS2.Range("A:A").Find(WS1.Range("A1"), , , xlWhole)
    
    If Not Apartment_No Is Nothing Then
        Set Find_Data = WS2.Rows(4).Find("KLİMA", , , xlWhole)
        If Not Find_Data Is Nothing Then
            First_Address = Find_Data.Address
            Do
                WS1.Cells(Satir, 1) = Find_Data.Offset(-1).Value
                WS1.Cells(Satir, 2) = WS2.Cells(Apartment_No.Row, Find_Data.Column).Value
                Satir = Satir + 1
                Set Find_Data = WS2.Rows(4).FindNext(Find_Data)
            Loop While Not Find_Data Is Nothing And Find_Data.Address <> First_Address
        End If
        
        WS1.Range("B2:B" & Satir).Style = "Currency"
        WS1.Columns("A:B").AutoFit
        
        WB2.Close False
        Application.ScreenUpdating = True
        
        MsgBox WS1.Range("A1") & " numaralı daireye ait borç listesi hazırlanmıştır.", vbInformation
    Else
        WB2.Close False
        Application.ScreenUpdating = True
        
        MsgBox WS1.Range("A1") & " numaralı daire bulunamadı!", vbCritical
    End If
    
    Set Apartment_No = Nothing
    Set Find_Data = Nothing
    Set WB1 = Nothing
    Set WS1 = Nothing
    Set WB2 = Nothing
    Set WS2 = Nothing
End Sub
Sayfadaki butonların kod bölümüne ise aşağıdaki kodu uygulayınız.

C++: 
Option Explicit

Private Sub CommandButton1_Click()
    Call Module1.Dogalgaz_Borc_Raporu
End Sub

Private Sub CommandButton2_Click()
    Call Module1.Klima_Borc_Raporu
End Sub
 
1

1mak1mak

Katılım
9 Ocak 2011
Mesajlar
354
Excel Vers. ve Dili
2007 Türkçe
Altın Üyelik Bitiş Tarihi
01-07-2023
Korhan Ayhan' Alıntı:
Deneyiniz.

Boş bir modüle aşağıdaki kodu uygulayınız.

C++: 
Option Explicit

Sub Dogalgaz_Borc_Raporu()
    Dim Yol As String, Dosya As String, WB1 As Workbook, WB2 As Workbook
    Dim WS1 As Worksheet, WS2 As Worksheet, Apartment_No As Range
    Dim Find_Data As Range, First_Address As String, Satir As Long
   
    Application.ScreenUpdating = False
   
    Set WB1 = ThisWorkbook
    Set WS1 = WB1.Sheets("Sayfa1")
   
    WS1.Range("A2:B" & WS1.Rows.Count).Clear
    Satir = 2
   
    Yol = WB1.Path & Application.PathSeparator
    Dosya = Yol & "Borç Listesi.xlsx"
   
    Set WB2 = Workbooks.Open(Dosya, False, False)
    Set WS2 = WB2.Sheets("D.Gaz1")
   
    Set Apartment_No = WS2.Range("A:A").Find(WS1.Range("A1"), , , xlWhole)
   
    If Not Apartment_No Is Nothing Then
        Set Find_Data = WS2.Rows(3).Find("Doğalgaz Borç", , , xlPart)
        If Not Find_Data Is Nothing Then
            First_Address = Find_Data.Address
            Do
                WS1.Cells(Satir, 1) = Find_Data.Value
                WS1.Cells(Satir, 2) = WS2.Cells(Apartment_No.Row, Find_Data.Column).Value
                Satir = Satir + 1
                Set Find_Data = WS2.Rows(3).FindNext(Find_Data)
            Loop While Not Find_Data Is Nothing And Find_Data.Address <> First_Address
        End If
       
        WS1.Range("B2:B" & Satir).Style = "Currency"
        WS1.Columns("A:B").AutoFit
       
        WB2.Close False
        Application.ScreenUpdating = True
       
        MsgBox WS1.Range("A1") & " numaralı daireye ait borç listesi hazırlanmıştır.", vbInformation
    Else
        WB2.Close False
        Application.ScreenUpdating = True
       
        MsgBox WS1.Range("A1") & " numaralı daire bulunamadı!", vbCritical
    End If
   
    Set Apartment_No = Nothing
    Set Find_Data = Nothing
    Set WB1 = Nothing
    Set WS1 = Nothing
    Set WB2 = Nothing
    Set WS2 = Nothing
End Sub

Sub Klima_Borc_Raporu()
    Dim Yol As String, Dosya As String, WB1 As Workbook, WB2 As Workbook
    Dim WS1 As Worksheet, WS2 As Worksheet, Apartment_No As Range
    Dim Find_Data As Range, First_Address As String, Satir As Long
   
    Application.ScreenUpdating = False
   
    Set WB1 = ThisWorkbook
    Set WS1 = WB1.Sheets("Sayfa1")
   
    WS1.Range("A2:B" & WS1.Rows.Count).Clear
    Satir = 2
   
    Yol = WB1.Path & Application.PathSeparator
    Dosya = Yol & "Borç Listesi.xlsx"
   
    Set WB2 = Workbooks.Open(Dosya, False, False)
    Set WS2 = WB2.Sheets("Klima")
   
    Set Apartment_No = WS2.Range("A:A").Find(WS1.Range("A1"), , , xlWhole)
   
    If Not Apartment_No Is Nothing Then
        Set Find_Data = WS2.Rows(4).Find("KLİMA", , , xlWhole)
        If Not Find_Data Is Nothing Then
            First_Address = Find_Data.Address
            Do
                WS1.Cells(Satir, 1) = Find_Data.Offset(-1).Value
                WS1.Cells(Satir, 2) = WS2.Cells(Apartment_No.Row, Find_Data.Column).Value
                Satir = Satir + 1
                Set Find_Data = WS2.Rows(4).FindNext(Find_Data)
            Loop While Not Find_Data Is Nothing And Find_Data.Address <> First_Address
        End If
       
        WS1.Range("B2:B" & Satir).Style = "Currency"
        WS1.Columns("A:B").AutoFit
       
        WB2.Close False
        Application.ScreenUpdating = True
       
        MsgBox WS1.Range("A1") & " numaralı daireye ait borç listesi hazırlanmıştır.", vbInformation
    Else
        WB2.Close False
        Application.ScreenUpdating = True
       
        MsgBox WS1.Range("A1") & " numaralı daire bulunamadı!", vbCritical
    End If
   
    Set Apartment_No = Nothing
    Set Find_Data = Nothing
    Set WB1 = Nothing
    Set WS1 = Nothing
    Set WB2 = Nothing
    Set WS2 = Nothing
End Sub
Sayfadaki butonların kod bölümüne ise aşağıdaki kodu uygulayınız.

C++: 
Option Explicit

Private Sub CommandButton1_Click()
    Call Module1.Dogalgaz_Borc_Raporu
End Sub

Private Sub CommandButton2_Click()
    Call Module1.Klima_Borc_Raporu
End Sub
Genişletmek için tıkla ...
Teşekkür ederim tam istediğim gibi olmuş elinize aklınıza sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst