Mevcut Kodda Değişim

Katılım
22 Ocak 2019
Mesajlar
92
Excel Vers. ve Dili
Excel 2010
Aşağıdaki kod; herhangi bir kelime yazıldığında, hangi sayfada sütunda ve satırda ise buluyor ve aranan kelimeyi bir sayfada köprüler oluşturuyor.

İstenilen; aranan kelime bulunduğunda, bir sonraki sütun ve satıra ait (Aynı satırda) verilerinde gelmesi.

Örneğin: Kelime arandığında bulunan sayfa-sütun-satır aşağıdaki gibi köprü oluşturuyor.

Ocak!B218 - İstenilen C218 - D218 Aynı satırdaki diğer verilerinde gelmesi
Ocak!L126 - İstenilen M126 - N126 Aynı satırdaki diğer verilerinde gelmesi
Ocak!O203 - İstenilen P203 - R203 Aynı satırdaki diğer verilerinde gelmesi

Kod:
Option Compare Text
Option Explicit

Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long

Const SM_CXSCREEN = 0
'Gets screen size to adjust column display
Private Function ScreenWidth()
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Function

Sub DoFindAll()
    'Arguements required for initial use in a workbook
    FindAll "", "True"
End Sub


Public Sub FindAll(Search As String, Reset As Boolean)

'Contrived from code by DRJ
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=159

Dim WB              As Workbook
Dim WS              As Worksheet
Dim Cell            As Range
Dim Prompt          As String
Dim Title           As String
Dim FindCell()      As String
Dim FindSheet()     As String
Dim FindWorkBook()  As String
Dim FindPath()      As String
Dim FindText()      As String
Dim Counter         As Long
Dim FirstAddress    As String
Dim Path            As String
Dim MyResponse      As VbMsgBoxResult

    If Search = "" Then
        Prompt = "Çalışma Kitabında Aramak İstediğinizi Yazın: " & vbNewLine & vbNewLine & Path
        Title = "Arama Menüsü"
        'Delete default search term if required
        Search = InputBox(Prompt, Title, "")
        If Search = "" Then
            GoTo Canceled
        End If
    End If
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   
    'Save found addresses and text into arrays
    On Error Resume Next
    Set WB = ActiveWorkbook
    If Err = 0 Then
        On Error GoTo 0
        For Each WS In WB.Worksheets
            'Omit results page from search
             If WS.Name <> "Aranan" Then
                           With WB.Sheets(WS.Name).Cells
                    Set Cell = .Find(What:=Search, after:=.SpecialCells(xlCellTypeLastCell), LookIn:=xlValues, LookAt:=xlPart, _
                        MatchCase:=False, SearchOrder:=xlByColumns)
                    If Not Cell Is Nothing Then
                        FirstAddress = Cell.Address
                        Do
                            Counter = Counter + 1
                            ReDim Preserve FindCell(1 To Counter)
                            ReDim Preserve FindSheet(1 To Counter)
                            ReDim Preserve FindWorkBook(1 To Counter)
                            ReDim Preserve FindPath(1 To Counter)
                            ReDim Preserve FindText(1 To Counter)
                            FindCell(Counter) = Cell.Address(False, False)
                            FindText(Counter) = Cell.Text
                            FindSheet(Counter) = WS.Name
                            FindWorkBook(Counter) = WB.Name
                            FindPath(Counter) = WB.FullName
                            Set Cell = .FindNext(Cell)
                        Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
                    End If
                End With
            End If
        Next
    End If
    On Error GoTo 0
    'Response if no text found
    If Counter = 0 Then
        MsgBox Search & " Bulunamadı.", vbInformation, "Arama Sonucu"
        Exit Sub
    End If
   
    'Create FindWord sheet in does not exist
    On Error Resume Next
    Sheets("Aranan").Select
    If Err.Number <> 0 Then
        'error occured so clear it
        Err.Clear
        Sheets.Add.Name = "Aranan"
        Sheets("Aranan").Move after:=Sheets(Sheets.Count)
        'Run macro to add code to ThisWorkbook
        AddSheetCode
    End If
   
    'Write hyperlinks and texts to FindWord
    Range("A3:B65536").ClearContents
    Range("A1:B1").Interior.ColorIndex = 8
    Range("A1").Value = "Aranan Kelime:"
    'Reset prevents looping of code when sheet changes
    If Reset = True Then Range("A1").Value = Search
    Range("A1:D2").Font.Bold = True
    Range("A2").Value = "Sayfa Sutun Satır"
    Range("B2").Value = "Bulunan"
    Range("A1:B1").HorizontalAlignment = xlLeft
    Range("A2:B2").HorizontalAlignment = xlCenter
    'Adjust screen size to suit
    Range("A:A").ColumnWidth = ScreenWidth / 60
    Range("B:B").ColumnWidth = ScreenWidth / 60
    For Counter = 1 To UBound(FindCell)
        ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
            Address:="", SubAddress:=Chr(39) & FindSheet(Counter) & Chr(39) & "!" & FindCell(Counter), _
            TextToDisplay:=FindSheet(Counter) & "!" & FindCell(Counter)
        Range("B" & Counter + 2).Value = FindText(Counter)
    Next Counter
    Range("B1").Select
   
Canceled:

    Set WB = Nothing
    Set WS = Nothing
    Set Cell = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
End Sub


Sub AddSheetCode()
    'Thanks to Dragontooth
    Dim strCode As String
    Dim FWord As String
    Dim WB As Workbook
    Dim Sh
    Dim I As Integer
    Set WB = ActiveWorkbook
   
    'Line to be inserted instead of 4th line below if code in Personal.xls
    '& "Application.Run (" & Chr(34) & "Personal.xls!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
    'Optional 4th line if code in workbook
    '& "FindAll Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _

    strCode = "Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)" & vbCr _
    & "If Sh.Name = " & Chr(34) & "Aranan" & Chr(34) & " Then" & vbCr _
    & "If Target.Address = " & Chr(34) & "$B$1" & Chr(34) & " Then" & vbCr _
    & "FindAll Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
    & "Cells(1,2).Select" & vbCr _
    & "End if" & vbCr _
    & "End if" & vbCr _
    & "End Sub"
   
    'Write code to ThisWorkbook module
    FWord = "ThisWorkbook"
    For I = 1 To WB.VBProject.VBComponents.Count
        If WB.VBProject.VBComponents.Item(I).Name = FWord Then
            Exit For
        End If
    Next
    If Not WB.VBProject.VBComponents.Item(I).CodeModule Is Nothing Then
        If Not WB.VBProject.VBComponents.Item(I).CodeModule.Find("Workbook_SheetChange", 1, 1, 100, 100) Then
            WB.VBProject.VBComponents.Item(I).CodeModule.AddFromString (strCode)
        End If
    End If
    Set WB = Nothing
   
End Sub
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
3,154
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba, sanırım diğer sorunuzdaki dosyanız da bu konuyla ilgili, buradan yazıyorum cevabı.

FindWord sayfanızdaki C-D-E sütunlarını tamamen kaldırın. C-D-E ye başlık koymak istiyorsanız koyun.
Aşağıdakileri yaptıktan sonra sonuçlar 3.satırdan itibaren ilave olarak C-D-E sütunlarına yazacaktır.

Public Sub FindAll(Search As String, Reset As Boolean) bu yordama aşağıdaki ilaveleri yapın.

1. Değişken tanımlaması kısmını aşağıdkai satırı ilave edin
C++:
Dim FindOtherColumns() As String
2. Do Loop döngüsünde işaretlediğim satırları gösterdiğim gibi ilave edin.
C++:
                        Do
                            Counter = Counter + 1
                            ReDim Preserve FindCell(1 To Counter)
                            ReDim Preserve FindSheet(1 To Counter)
                            ReDim Preserve FindWorkBook(1 To Counter)
                            ReDim Preserve FindPath(1 To Counter)
                            ReDim Preserve FindText(1 To Counter)
                            FindCell(Counter) = Cell.Address(False, False)
                            FindText(Counter) = Cell.Text
                            FindSheet(Counter) = WS.Name
                            FindWorkBook(Counter) = WB.Name
                            FindPath(Counter) = WB.FullName
                            '......................
                            'İlave satırlar
                            ReDim Preserve FindOtherColumns(1 To 3, 1 To Counter)
                            FindOtherColumns(1, Counter) = Cell.Offset(0, 1).Value
                            FindOtherColumns(2, Counter) = Cell.Offset(0, 2).Value
                            FindOtherColumns(3, Counter) = Cell.Offset(0, 3).Value
                            '...................
                            Set Cell = .FindNext(Cell)
                        Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
3. Son olarakda yordamın alt kısmındaki bu bölgeye işaretlediğim satırlar da kopyalayın.
C++:
    For Counter = 1 To UBound(FindCell)
        ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
            Address:="", SubAddress:=Chr(39) & FindSheet(Counter) & Chr(39) & "!" & FindCell(Counter), _
            TextToDisplay:=FindSheet(Counter) & "!" & FindCell(Counter)
        Range("B" & Counter + 2).Value = FindText(Counter)
    Next Counter
    '........................................................
    'İlave satırla
    If LBound(FindCell) > 0 Then
    Range("C3:E" & Rows.Count).ClearContents
    Range("C3").Resize(UBound(FindCell), 3) = Application.Transpose(FindOtherColumns)
    Range("A:E").Columns.AutoFit
    End If
    '............................................................
    Range("B1").Select
Canceled:
 
Katılım
22 Ocak 2019
Mesajlar
92
Excel Vers. ve Dili
Excel 2010
Kodlar çalışıyor herhangi bir problem yok, çook teşekkür ederim... Allah razı olsun...

Aranan kelime öncesinde tarihlerim vardı,
(A-G Sütunlarında) Bunları da getirme şansım var mı? (Sonradan iş çıkarttınız derseniz kesinlikle dikkate almayın.)

Allah siz ve sizin gibi yardımseverlere; Hz.Ömer adaleti, Hz.Osman zenginliği, Hz.Ebu Bekir takvası, Hz.Hamza gücü, Hz.Ali ilmi, Hz.Muhammed (S.A.V) efendimizin şefaatini versin inşALLAH...
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
3,154
Excel Vers. ve Dili
Ofis 365 Türkçe
Ben de bir kaç soru sorayım.
  1. Aranacak kelime hiç bir zaman A sütununda olmayacak değil mi?
  2. Aranacak kelime öncesinde derken bir önceki sütunda mı? Yoksa A sütununda mı?
  3. İlk mesajda istediklerinizi C-D_E sütunlarına getirmiştiniz. Tarih değeri hangi sütuna getirilecek?
 
Katılım
22 Ocak 2019
Mesajlar
92
Excel Vers. ve Dili
Excel 2010
1-Aranacak kelime kesinlikle A ve G sütunlarında değil, çünkü buralarda tarih var.
2-Tarihler, (A-G Sütunlarında) aranılan her verinin önünde yer almaktadır.
3-İstenilen tarih, C-D-E dışında herhangi bir sütuna gelebilir, F olabilir G olabilir fark etmez, önemli olan gelmesi.


Çok kapsamlı ve yorucu zaman alıcı bir durum ise, lütfen dikkate almayın.
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
3,154
Excel Vers. ve Dili
Ofis 365 Türkçe
Her verinin önünde ifadesini bir önceki sütun olarak algılıyorum.
Tarihleri F sütununa yazdırıyorum.
Bu durumda aşağıdaki satırlarda ilave ve/veya düzeltme yapmalısınız.
C++:
   'düzeltme 1
   ReDim Preserve FindOtherColumns(1 To 4, 1 To Counter)
   FindOtherColumns(1, Counter) = Cell.Offset(0, 1).Value
   FindOtherColumns(2, Counter) = Cell.Offset(0, 2).Value
   FindOtherColumns(3, Counter) = Cell.Offset(0, 3).Value
   'İlave satır 2
   FindOtherColumns(4, Counter) = Cell.Offset(0, -1).Value
C++:
    If LBound(FindCell) > 0 Then
    'Düzeltme 3
    Range("C3:F" & Rows.Count).ClearContents
    'Düzeltme 4
    Range("C3").Resize(UBound(FindCell), 4) = Application.Transpose(FindOtherColumns)
    'İlave 5
    Range("F:F").NumberFormat="dd.mm.yyyy"
    Range("A:F").Columns.AutoFit
    End If
 
Katılım
22 Ocak 2019
Mesajlar
92
Excel Vers. ve Dili
Excel 2010
Maalesef hata verdi Run Time Error 1004 (İsterseniz burada bırakalım, hata benimde olabilir, zamanınızı çalmayım)

Kod:
Option Compare Text
Option Explicit

Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long

Const SM_CXSCREEN = 0
'Gets screen size to adjust column display
Private Function ScreenWidth()
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Function

Sub DoFindAll()
    'Arguements required for initial use in a workbook
    FindAll "", "True"
End Sub


Public Sub FindAll(Search As String, Reset As Boolean)

'Contrived from code by DRJ
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=159

Dim WB              As Workbook
Dim WS              As Worksheet
Dim Cell            As Range
Dim Prompt          As String
Dim Title           As String
Dim FindCell()      As String
Dim FindSheet()     As String
Dim FindWorkBook()  As String
Dim FindPath()      As String
Dim FindText()      As String
Dim Counter         As Long
Dim FirstAddress    As String
Dim Path            As String
Dim MyResponse      As VbMsgBoxResult
Dim FindOtherColumns() As String

    If Search = "" Then
        Prompt = "Çalışma Kitabında Aramak İstediğinizi Yazın: " & vbNewLine & vbNewLine & Path
        Title = "Arama Menüsü"
        'Delete default search term if required
        Search = InputBox(Prompt, Title, "")
        If Search = "" Then
            GoTo Canceled
        End If
    End If
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   
    'Save found addresses and text into arrays
    On Error Resume Next
    Set WB = ActiveWorkbook
    If Err = 0 Then
        On Error GoTo 0
        For Each WS In WB.Worksheets
            'Omit results page from search
            If WS.Name <> "Aranan" Then
                With WB.Sheets(WS.Name).Cells
                    Set Cell = .Find(What:=Search, after:=.SpecialCells(xlCellTypeLastCell), LookIn:=xlValues, LookAt:=xlPart, _
                        MatchCase:=False, SearchOrder:=xlByColumns)
                    If Not Cell Is Nothing Then
                        FirstAddress = Cell.Address
                        Do
                            Counter = Counter + 1
                            ReDim Preserve FindCell(1 To Counter)
                            ReDim Preserve FindSheet(1 To Counter)
                            ReDim Preserve FindWorkBook(1 To Counter)
                            ReDim Preserve FindPath(1 To Counter)
                            ReDim Preserve FindText(1 To Counter)
                            FindCell(Counter) = Cell.Address(False, False)
                            FindText(Counter) = Cell.Text
                            FindSheet(Counter) = WS.Name
                            FindWorkBook(Counter) = WB.Name
                            FindPath(Counter) = WB.FullName
                            ReDim Preserve FindOtherColumns(1 To 4, 1 To Counter)
   FindOtherColumns(1, Counter) = Cell.Offset(0, 1).Value
   FindOtherColumns(2, Counter) = Cell.Offset(0, 2).Value
   FindOtherColumns(3, Counter) = Cell.Offset(0, 3).Value
   FindOtherColumns(4, Counter) = Cell.Offset(0, -1).Value
   Set Cell = .FindNext(Cell)
                        Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
                    End If
                End With
            End If
        Next
    End If
    On Error GoTo 0
    'Response if no text found
    If Counter = 0 Then
        MsgBox Search & " Aranan bulunamadı.", vbInformation, "Arama Sonucu"
        Exit Sub
    End If
   
    'Create FindWord sheet in does not exist
    On Error Resume Next
    Sheets("Aranan").Select
    If Err.Number <> 0 Then
        'error occured so clear it
        Err.Clear
        Sheets.Add.Name = "Aranan"
        Sheets("Aranan").Move after:=Sheets(Sheets.Count)
        'Run macro to add code to ThisWorkbook
        AddSheetCode
    End If
   
    'Write hyperlinks and texts to FindWord
    Range("A3:B65536").ClearContents
    Range("A1:B1").Interior.ColorIndex = 8
    Range("A1").Value = "Aranan Kelime:"
    'Reset prevents looping of code when sheet changes
    If Reset = True Then Range("B1").Value = Search
    Range("A1:D2").Font.Bold = True
    Range("A2").Value = "Sayfa Sutun Satır"
    Range("B2").Value = "Bulunan"
    Range("A1:B1").HorizontalAlignment = xlLeft
    Range("A2:B2").HorizontalAlignment = xlCenter
    'Adjust screen size to suit
    Range("A:A").ColumnWidth = ScreenWidth / 60
    Range("B:B").ColumnWidth = ScreenWidth / 60
    For Counter = 1 To UBound(FindCell)
        ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
            Address:="", SubAddress:=Chr(39) & FindSheet(Counter) & Chr(39) & "!" & FindCell(Counter), _
            TextToDisplay:=FindSheet(Counter) & "!" & FindCell(Counter)
        Range("B" & Counter + 2).Value = FindText(Counter)
    Next Counter
     If LBound(FindCell) > 0 Then
    'Düzeltme 3
    Range("C3:F" & Rows.Count).ClearContents
    'Düzeltme 4
    Range("C3").Resize(UBound(FindCell), 4) = Application.Transpose(FindOtherColumns)
    'İlave 5
    Range("F:F").NumberFormat = "dd.mm.yyyy"
    Range("A:F").Columns.AutoFit
    End If
    Range("B1").Select
   
   
Canceled:

    Set WB = Nothing
    Set WS = Nothing
    Set Cell = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
End Sub


Sub AddSheetCode()
    'Thanks to Dragontooth
    Dim strCode As String
    Dim FWord As String
    Dim WB As Workbook
    Dim Sh
    Dim I As Integer
    Set WB = ActiveWorkbook
   
    'Line to be inserted instead of 4th line below if code in Personal.xls
    '& "Application.Run (" & Chr(34) & "Personal.xls!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
    'Optional 4th line if code in workbook
    '& "FindAll Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _

    strCode = "Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)" & vbCr _
    & "If Sh.Name = " & Chr(34) & "Aranan" & Chr(34) & " Then" & vbCr _
    & "If Target.Address = " & Chr(34) & "$B$1" & Chr(34) & " Then" & vbCr _
    & "FindAll Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
    & "Cells(1,2).Select" & vbCr _
    & "End if" & vbCr _
    & "End if" & vbCr _
    & "End Sub"
   
    'Write code to ThisWorkbook module
    FWord = "ThisWorkbook"
    For I = 1 To WB.VBProject.VBComponents.Count
        If WB.VBProject.VBComponents.Item(I).Name = FWord Then
            Exit For
        End If
    Next
    If Not WB.VBProject.VBComponents.Item(I).CodeModule Is Nothing Then
        If Not WB.VBProject.VBComponents.Item(I).CodeModule.Find("Workbook_SheetChange", 1, 1, 100, 100) Then
            WB.VBProject.VBComponents.Item(I).CodeModule.AddFromString (strCode)
        End If
    End If
    Set WB = Nothing
   
End Sub
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
3,154
Excel Vers. ve Dili
Ofis 365 Türkçe
Hata verdiği satır hangisidir?
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
3,154
Excel Vers. ve Dili
Ofis 365 Türkçe
Aranan verinin herhangi bir sayfada A sütununda olmadığına emin misiniz?
 
Katılım
22 Ocak 2019
Mesajlar
92
Excel Vers. ve Dili
Excel 2010
Kesinlikle aranan veri A Sütununda değil, tarihler A ve G Sütunlarında...

Fazlası ile yardımcı oldunuz, hatta program yaptınız başlı başına. Allah sizden razı olsun. Bu kadarına da şükür. Çok amaa Çokk teşekkürler...
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
3,154
Excel Vers. ve Dili
Ofis 365 Türkçe
Amin.

Gönderdiğiniz dosyada Sayfa1 de A8 hücresinde deneme 1 yazıyor ve o sayfada mecburen hata veriyor.
Sizden şunu bekliyorum.
Kod hata verdiğinde, hata veren satırın biraz üstündeki şu satırların Mouse ile kırmızı kısmında üzerine gelince aldığı değer nedir?

FindCell(Counter) = Cell.Address(False, False)
FindText(Counter) = Cell.Text
FindSheet(Counter) = WS.Name
FindWorkBook(Counter) = WB.Name
FindPath(Counter) =
WB.FullName
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
3,154
Excel Vers. ve Dili
Ofis 365 Türkçe
Dosyanız hata vermiyor. Sadece tarihleri alamamış.
Bahseetiğiniz hata veren satır FindOtherColumns(4, Counter) = Cell.Offset(0, -1).Value yerine aşağıdkaini yazın lütfen.

C++:
If Cell.Column < 7 Then
  FindOtherColumns(4, Counter) = WB.Sheets(WS.Name).Cells(Cell.Row, 1)
Else
  FindOtherColumns(4, Counter) = WB.Sheets(WS.Name).Cells(Cell.Row, 7)
End If
 
Katılım
22 Ocak 2019
Mesajlar
92
Excel Vers. ve Dili
Excel 2010
Dosya yeniden inşa edildi, nasıl teşekkür edeceğimi bilemedim, ayrıca özürüm kabahatimden büyük inanın. Özür dilerim hakkınızı lütfen helal edin :(

Allah hakkınızda hayırlısını güzel eylesin. Sağ olun var olun...
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
3,154
Excel Vers. ve Dili
Ofis 365 Türkçe
Özüre gerek yok. Hakkım varsa da helal olsun.
Allah hepimiz hakkında hayırlısını versin.
 
Üst