Sorgu yapıldığında mükerrer başvuru var ise bilgisinin çekilmesi

[neonkratos]

Kolay gelsin arkadaşlar. Forumda aradım ama tam istediğim gibi bir cevap bulamadım. Yardımcı olursanız sevinirim.

"Bilgi Girişi" sayfasında F2 hücresinde sorgu yaptığımda; "İnceleme Cetveli" nde bilgiler geliyor. Bu bilgilerde C16 hücresindeki şeflikte kalan C17 hücresindeki Bölme Numaralarına, "Bilgiler" Cetvelindeki H sütununda aynı şeflikte kalan I sütunundaki bölmelerde mükerrer başvuru var ise bu başvuruların sıra numaralarının yazılmasını istiyorum. Yapılabilir mi bilmiyorum ama olursa gerçekten çok memnun olurum.

 

[neonkratos]

Sanırım olmuyor

 

[catalinastrap]

Merhaba,
Tıkla makrosuna ilave yazdım bu şekilde tamamını kopyalayıp kayıt yapar gibi deneyebilirmisiniz




Sub Dikdörtgen1_Tıkla()

Dim wsBilgi As Worksheet, wsInceleme As Worksheet
Dim sonSatirBilgi As Long, sonSatirInceleme As Long
Dim sef As String, bolme As Variant, bolmeler As Variant
Dim i As Long, j As Long, sayac As Long
Dim sonuc As String

Set wsBilgi = ThisWorkbook.Sheets("Bilgiler")
Set wsInceleme = ThisWorkbook.Sheets("İnceleme Cetveli")

sef = wsInceleme.Range("C16").Value
bolmeler = Split(wsInceleme.Range("C17").Value, ",")

For i = LBound(bolmeler) To UBound(bolmeler)
sonuc = ""
sayac = 0
For j = 2 To wsBilgi.Cells(wsBilgi.Rows.Count, "A").End(xlUp).Row
If wsBilgi.Cells(j, "H").Value = sef And wsBilgi.Cells(j, "I").Value = Trim(bolmeler(i)) Then
' Aynı şeflik ve bölmede kaç tane başvuru var?
If Application.WorksheetFunction.CountIfs(wsBilgi.Range("H:H"), sef, wsBilgi.Range("I:I"), Trim(bolmeler(i))) > 1 Then
If sonuc <> "" Then sonuc = sonuc & ", "
sonuc = sonuc & wsBilgi.Cells(j, "A").Value
sayac = sayac + 1
End If
End If
Next j
wsInceleme.Range("D" & 18 + i).Value = sonuc
Next i


Range("A2:C2").Select
Selection.Copy
Sheets("Sorgu Cetveli").Select
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("B3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Bilgi Girişi").Select
Range("E2").Select
End Sub

 

[neonkratos]

Merhaba,
Tıkla makrosuna ilave yazdım bu şekilde tamamını kopyalayıp kayıt yapar gibi deneyebilirmisiniz




Sub Dikdörtgen1_Tıkla()

Dim wsBilgi As Worksheet, wsInceleme As Worksheet
Dim sonSatirBilgi As Long, sonSatirInceleme As Long
Dim sef As String, bolme As Variant, bolmeler As Variant
Dim i As Long, j As Long, sayac As Long
Dim sonuc As String

Set wsBilgi = ThisWorkbook.Sheets("Bilgiler")
Set wsInceleme = ThisWorkbook.Sheets("İnceleme Cetveli")

sef = wsInceleme.Range("C16").Value
bolmeler = Split(wsInceleme.Range("C17").Value, ",")

For i = LBound(bolmeler) To UBound(bolmeler)
sonuc = ""
sayac = 0
For j = 2 To wsBilgi.Cells(wsBilgi.Rows.Count, "A").End(xlUp).Row
If wsBilgi.Cells(j, "H").Value = sef And wsBilgi.Cells(j, "I").Value = Trim(bolmeler(i)) Then
' Aynı şeflik ve bölmede kaç tane başvuru var?
If Application.WorksheetFunction.CountIfs(wsBilgi.Range("H:H"), sef, wsBilgi.Range("I:I"), Trim(bolmeler(i))) > 1 Then
If sonuc <> "" Then sonuc = sonuc & ", "
sonuc = sonuc & wsBilgi.Cells(j, "A").Value
sayac = sayac + 1
End If
End If
Next j
wsInceleme.Range("D" & 18 + i).Value = sonuc
Next i


Range("A2:C2").Select
Selection.Copy
Sheets("Sorgu Cetveli").Select
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("B3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Bilgi Girişi").Select
Range("E2").Select
End Sub

Hocam kopyaladım da olmadı. Dikdörtgen1 makrosu deneme yapmıştım gereksiz makro. O olmadan yazabilir misiniz. Beceremedim ben

 

[catalinastrap]

Diğer makrodaki şu boşluğa ilave edebilirsiniz

Sub Deneme_1()
Dim BosHucre As Long
Dim wsBilgi As Worksheet, wsInceleme As Worksheet
Dim sonSatirBilgi As Long, sonSatirInceleme As Long
Dim sef As String, bolme As Variant, bolmeler As Variant
Dim i As Long, j As Long, sayac As Long
Dim sonuc As String

Set wsBilgi = ThisWorkbook.Sheets("Bilgiler")
Set wsInceleme = ThisWorkbook.Sheets("İnceleme Cetveli")

sef = wsInceleme.Range("C16").Value
bolmeler = Split(wsInceleme.Range("C17").Value, ",")

For i = LBound(bolmeler) To UBound(bolmeler)
sonuc = ""
sayac = 0
For j = 2 To wsBilgi.Cells(wsBilgi.Rows.Count, "A").End(xlUp).Row
If wsBilgi.Cells(j, "H").Value = sef And wsBilgi.Cells(j, "I").Value = Trim(bolmeler(i)) Then
' Aynı şeflik ve bölmede kaç tane başvuru var?
If Application.WorksheetFunction.CountIfs(wsBilgi.Range("H:H"), sef, wsBilgi.Range("I:I"), Trim(bolmeler(i))) > 1 Then
If sonuc <> "" Then sonuc = sonuc & ", "
sonuc = sonuc & wsBilgi.Cells(j, "A").Value
sayac = sayac + 1
End If
End If
Next j
wsInceleme.Range("D" & 18 + i).Value = sonuc
Next i
Set ws1 = Worksheets("Bilgi Girişi")
Set ws2 = Worksheets("Bilgiler")

 

[neonkratos]

Diğer makrodaki şu boşluğa ilave edebilirsiniz

Sub Deneme_1()
Dim BosHucre As Long
Dim wsBilgi As Worksheet, wsInceleme As Worksheet
Dim sonSatirBilgi As Long, sonSatirInceleme As Long
Dim sef As String, bolme As Variant, bolmeler As Variant
Dim i As Long, j As Long, sayac As Long
Dim sonuc As String

Set wsBilgi = ThisWorkbook.Sheets("Bilgiler")
Set wsInceleme = ThisWorkbook.Sheets("İnceleme Cetveli")

sef = wsInceleme.Range("C16").Value
bolmeler = Split(wsInceleme.Range("C17").Value, ",")

For i = LBound(bolmeler) To UBound(bolmeler)
sonuc = ""
sayac = 0
For j = 2 To wsBilgi.Cells(wsBilgi.Rows.Count, "A").End(xlUp).Row
If wsBilgi.Cells(j, "H").Value = sef And wsBilgi.Cells(j, "I").Value = Trim(bolmeler(i)) Then
' Aynı şeflik ve bölmede kaç tane başvuru var?
If Application.WorksheetFunction.CountIfs(wsBilgi.Range("H:H"), sef, wsBilgi.Range("I:I"), Trim(bolmeler(i))) > 1 Then
If sonuc <> "" Then sonuc = sonuc & ", "
sonuc = sonuc & wsBilgi.Cells(j, "A").Value
sayac = sayac + 1
End If
End If
Next j
wsInceleme.Range("D" & 18 + i).Value = sonuc
Next i
Set ws1 = Worksheets("Bilgi Girişi")
Set ws2 = Worksheets("Bilgiler")

Hocam yeni bir şekle ekledim (Diğeri bilgi ekleme ona bağlayamam da) yine olmadı. Sonucu 'Bilgi Girişi F5' e yazsa olur mu. Bir de sorgu yaparken bölme numaralarını ayırıp bu numaralara göre mi yapıyor. Yani mesela kayıtta şahısın başvurusu 2 bölme de kalıyor. Diyelim ki 100 ve 150 bölme olsun. Makro; hem 100 bölmeyi sorgulayacak hemde 150'yi. aynı şekilde başvuru yapanı değil. Ben formülle 'Bilgiler' cetvelinde R:V sütunlarına formülle ayırtmıştım deneme için formülle becerememiştim

 

[neonkratos]

Darladığımın farkındayım kusura bakmayın. Çözümü olabilecek birisi var mıdır ?