VBA ile değer bulma ve yazma

C

chausin

Katılım
22 Kasım 2005
Mesajlar
11
Excel Vers. ve Dili
Excel 2016
Sheet1 de G1 hücresindeki değeri aratmak ve diğer tüm çalışma alanlarında bulup ve yanındaki değeri de alarak

a2 - b2 hücrelerine yazdırmak istiyorum. Aynı değerden 3 tane var ise
A3 - b3
A4 - b4 ‘lere gelecek şekilde nasıl yapabilirim.

diğer çalışmak alanlarında aranan (a) kısmı sabit ama (b) sütunundaki veri değişken olabiliyor.
 
TiOr

TiOr

Katılım
17 Mart 2022
Mesajlar
281
Excel Vers. ve Dili
2016/Türkçe
Altın Üyelik Bitiş Tarihi
22-03-2023
Selam,

Arama için aşağıdaki kodu kullanabilirsiniz ve kendinize uyarlarsınız; Örnek dosya olmadığı için kod bilgisi paylaşmaktan başka bir çare gözükmüyor.

Kod: 
Private Sub TextBox6_Change()

    If Len(TextBox6.Value) < 8 Then Exit Sub
    
On Error GoTo Bitir
 Cells.Interior.ColorIndex = xlColorIndexNone
 Dim fc As Range ' FindCell = Aranan Hücre
 Set fc = Worksheets("DATA").Columns("A").Find(What:=TextBox32, LookAt:=xlWhole)
 fc.Select
 ActiveCell.Cells.Interior.ColorIndex = 4
 X = ActiveCell.Row
 Y = ActiveCell.Column
 
 MsgBox "ARADIĞINIZ ÖZEL KOD İLE İLGİLİ İLK KAYIT " & vbNewLine & vbNewLine & X & ". SATIRDA " & Y & ". SÜTUNDADIR.", vbInformation, "BULUNDU..."


    TextBox1.Value = Worksheets("DATA").Cells(X, 1)
    TextBox2.Value = Worksheets("DATA").Cells(X, 2)
    TextBox3.Value = Worksheets("DATA").Cells(X, 3)
    TextBox4.Value = Worksheets("DATA").Cells(X, 4)
    TextBox5.Value = Worksheets("DATA").Cells(X, 5)
 
    
    TextBox6.Value = ""
    TextBox6.SetFocus

Exit Sub
Bitir: MsgBox "ARANAN KAYIT BULUNAMADI"

End Sub

Arama işlemi akabinde aranan değere bağlı satırlarda değişikliği aşağıdaki kod ile yapabilirsiniz;

Kod: 
Private Sub CommandButton4_Click() 'DEĞİŞTİR
On Error GoTo Bitir
aranan = TextBox1.Value
Range("A:A").Find(aranan).Select
değiştir_satır = ActiveCell.Row

Worksheets("Data").Cells(değiştir_satır, 1) = TextBox1.Value
Worksheets("Data").Cells(değiştir_satır, 2) = TextBox2.Value
Worksheets("Data").Cells(değiştir_satır, 3) = TextBox3.Value
Worksheets("Data").Cells(değiştir_satır, 4) = TextBox4.Value
Worksheets("Data").Cells(değiştir_satır, 5) = TextBox5.Value


Bitir:
End Sub
 
C

chausin

Katılım
22 Kasım 2005
Mesajlar
11
Excel Vers. ve Dili
Excel 2016
Cevabınız için teşekkür ederim ama benim yapmak istediğim excel satır ve sütunlarda
Textboxlar ile değil. Excel dosyayı ekliyorum. F1 hücresine “LCD” yazdığımda ARA çalışma alanı hariç tüm çalışma alanındaki LCD geçen verileri değerleri ile listelemek.

1drv.ms

Microsoft OneDrive - Access files anywhere. Create docs with free Office Online.

Store photos and docs online. Access them from any PC, Mac or phone. Create and work together on Word, Excel or PowerPoint documents.
1drv.ms

TiOr' Alıntı:
Selam,

Arama için aşağıdaki kodu kullanabilirsiniz ve kendinize uyarlarsınız; Örnek dosya olmadığı için kod bilgisi paylaşmaktan başka bir çare gözükmüyor.

Kod: 
Private Sub TextBox6_Change()

    If Len(TextBox6.Value) < 8 Then Exit Sub
   
On Error GoTo Bitir
Cells.Interior.ColorIndex = xlColorIndexNone
Dim fc As Range ' FindCell = Aranan Hücre
Set fc = Worksheets("DATA").Columns("A").Find(What:=TextBox32, LookAt:=xlWhole)
fc.Select
ActiveCell.Cells.Interior.ColorIndex = 4
X = ActiveCell.Row
Y = ActiveCell.Column

MsgBox "ARADIĞINIZ ÖZEL KOD İLE İLGİLİ İLK KAYIT " & vbNewLine & vbNewLine & X & ". SATIRDA " & Y & ". SÜTUNDADIR.", vbInformation, "BULUNDU..."


    TextBox1.Value = Worksheets("DATA").Cells(X, 1)
    TextBox2.Value = Worksheets("DATA").Cells(X, 2)
    TextBox3.Value = Worksheets("DATA").Cells(X, 3)
    TextBox4.Value = Worksheets("DATA").Cells(X, 4)
    TextBox5.Value = Worksheets("DATA").Cells(X, 5)

   
    TextBox6.Value = ""
    TextBox6.SetFocus

Exit Sub
Bitir: MsgBox "ARANAN KAYIT BULUNAMADI"

End Sub

Arama işlemi akabinde aranan değere bağlı satırlarda değişikliği aşağıdaki kod ile yapabilirsiniz;

Kod: 
Private Sub CommandButton4_Click() 'DEĞİŞTİR
On Error GoTo Bitir
aranan = TextBox1.Value
Range("A:A").Find(aranan).Select
değiştir_satır = ActiveCell.Row

Worksheets("Data").Cells(değiştir_satır, 1) = TextBox1.Value
Worksheets("Data").Cells(değiştir_satır, 2) = TextBox2.Value
Worksheets("Data").Cells(değiştir_satır, 3) = TextBox3.Value
Worksheets("Data").Cells(değiştir_satır, 4) = TextBox4.Value
Worksheets("Data").Cells(değiştir_satır, 5) = TextBox5.Value


Bitir:
End Sub
Genişletmek için tıkla ...
 
Korhan Ayhan

Korhan Ayhan

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

C++: 
Option Explicit

Sub Search_For_Products_On_Pages()
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
    Dim S1 As Worksheet, Sh As Worksheet, Find_Data As String
    
    Application.ScreenUpdating = False
    
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
    Set My_Recordset = VBA.CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("URUNARA")
    
    S1.Range("A2:C" & S1.Rows.Count).Clear
    
    Find_Data = S1.Range("F1").Value
    Find_Data = UCase(Replace(Replace(Find_Data, "ı", "I"), "i", "İ"))
    
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name <> S1.Name Then
            My_Query = "Select * From [" & Sh.Name & "$A2:B] Where F1 Like '%" & Find_Data & "%'"
            My_Recordset.Open My_Query, My_Connection, 1, 1
            If My_Recordset.RecordCount > 0 Then
                S1.Cells(S1.Rows.Count, 1).End(3)(2, 1).Resize(My_Recordset.RecordCount) = Sh.Name
                S1.Cells(S1.Rows.Count, 2).End(3)(2, 1).CopyFromRecordset My_Recordset
            End If
            My_Recordset.Close
        End If
    Next

    My_Connection.Close

    S1.Columns("A:C").AutoFit
    
    Application.ScreenUpdating = True

    If S1.Range("A2") = "" Then
        MsgBox "Kriterle eşleşen ürün bulunamadı!", vbCritical
    Else
        MsgBox "Kritere uygun " & S1.Cells(S1.Rows.Count, 1).End(3).Row - 1 & " adet ürün bulundu...", vbInformation
    End If

    Set My_Connection = Nothing
    Set My_Recordset = Nothing
    Set S1 = Nothing
End Sub
 
C

chausin

Katılım
22 Kasım 2005
Mesajlar
11
Excel Vers. ve Dili
Excel 2016
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Option Explicit

Sub Search_For_Products_On_Pages()
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
    Dim S1 As Worksheet, Sh As Worksheet, Find_Data As String
   
    Application.ScreenUpdating = False
   
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
    Set My_Recordset = VBA.CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("URUNARA")
   
    S1.Range("A2:C" & S1.Rows.Count).Clear
   
    Find_Data = S1.Range("F1").Value
    Find_Data = UCase(Replace(Replace(Find_Data, "ı", "I"), "i", "İ"))
   
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
   
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name <> S1.Name Then
            My_Query = "Select * From [" & Sh.Name & "$A2:B] Where F1 Like '%" & Find_Data & "%'"
            My_Recordset.Open My_Query, My_Connection, 1, 1
            If My_Recordset.RecordCount > 0 Then
                S1.Cells(S1.Rows.Count, 1).End(3)(2, 1).Resize(My_Recordset.RecordCount) = Sh.Name
                S1.Cells(S1.Rows.Count, 2).End(3)(2, 1).CopyFromRecordset My_Recordset
            End If
            My_Recordset.Close
        End If
    Next

    My_Connection.Close

    S1.Columns("A:C").AutoFit
   
    Application.ScreenUpdating = True

    If S1.Range("A2") = "" Then
        MsgBox "Kriterle eşleşen ürün bulunamadı!", vbCritical
    Else
        MsgBox "Kritere uygun " & S1.Cells(S1.Rows.Count, 1).End(3).Row - 1 & " adet ürün bulundu...", vbInformation
    End If

    Set My_Connection = Nothing
    Set My_Recordset = Nothing
    Set S1 = Nothing
End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim süper olmuş ellerine sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst