Metin içerisinde SEARCH Yapmak

[teo_64]

Merhaba,

macro ile j sutununda bulunan numaraları b ve c sutununda arama yaparak bulduğu numaraları d ve e sutununa yazmasını istiyorum bunu nasıl yapabilirim yardımlarınızı rica ederim
http://www.dosyaupload.com/18P2

 

[Asri]

Dosyanızda bir düzen yok,

* ID lerin başında sıfır yok, ancak B ve C kolonlarında sıfır ile başlayanda var başlamayanda.
* ID B ve C kolonunda 040136 , _040136 , 040136_ şeklinde bulunabiliyor.
* Sadece ID yi alıp metnin içinde aramak sağlıklı olmaz ID uzun sayıların içinde de sayısal olarak bulunabilir.

Sonuç olarak dosyanızın orjinal hali bu mudur?

* ID ne ise onu arasın var yazsın yok ise yazmasın mı?
* ID nin başına sıfır ekleyip arasın, sonra sıfır eklemeden arasın mı? (bu şekilde istenmeyen sonuçlar alınabilir)
* Ben ID nin başına sıfır eklerim, ID ne ise o şekilde arasın mı? diyorsunuz?

 

[teo_64]

Merhaba,

Dosyanın orjinali bu (Dosya çok dengesiz olduğu için bende bilemedim

*metin içersinde varsa o id numasını c ve d yazsın
* ıd başına 0 ekleyerekte arama yapılabilir

 

[Asri]

Merhaba,

Dosyanın orjinali bu (Dosya çok dengesiz olduğu için bende bilemedim

*metin içersinde varsa o id numasını c ve d yazsın
* ıd başına 0 ekleyerekte arama yapılabilir

ID ler en fazla kaç karakter uzunluğundadır

 

[Asri]

Kontrol ediniz.

Kurallar,
* ID sıfır ile başlar
- başında ve sonunda boşluk olanlar
- başında boşluk sonunda tire olan
- başında tire sonunda boşluk olan

* ID sıfır ile başlamaz
- başında ve sonunda boşlul olanlar
- başında boşluk sonunda tire olan
- başında tire sonunda boşluk olan

Sub buluver()
    Dim veridi As String
    Application.ScreenUpdating = False
    Sheets("Sheet1").Select
    sonsatira = Cells(Rows.Count, "A").End(3).Row
    sonsatirj = Cells(Rows.Count, "J").End(3).Row
   
    Range("D2:E" & sonsatira).Select
    Selection.ClearContents
    
    For i = 2 To sonsatirj
      veriid = Cells(i, "J").Value
      veriid1 = " " & Cells(i, "J").Value & " "
      veriid2 = " " & Cells(i, "J").Value & "_"
      veriid3 = "_" & Cells(i, "J").Value & " "
      
      veriid0 = "0" & Cells(i, "J").Value
      veriid01 = " " & veriid0 & " "
      veriid02 = " " & veriid0 & "_"
      veriid03 = "_" & veriid0 & " "
          
      buldu = False
      For j = 2 To sonsatira
        verib = Cells(j, "B").Value
        veric = Cells(j, "C").Value
        If InStr(verib, veriid1) > 0 Or InStr(verib, veriid2) > 0 Or InStr(verib, veriid3) > 0 Then
           buldu = True
        End If
        
        If InStr(veric, veriid1) > 0 Or InStr(veric, veriid2) > 0 Or InStr(veric, veriid3) > 0 Then
           buldu = True
        End If
        
        If InStr(verib, veriid01) > 0 Or InStr(verib, veriid02) > 0 Or InStr(verib, veriid03) > 0 Then
           buldu = True
        End If
        
        If InStr(veric, veriid01) > 0 Or InStr(veric, veriid02) > 0 Or InStr(veric, veriid03) > 0 Then
           buldu = True
        End If
        
        
        If buldu Then
           Cells(j, "D").Value = "'" & veriid
           Cells(j, "E").Value = "'" & veriid
           buldu = False
        End If
      Next j
        
    Next i
    
   Application.ScreenUpdating = True
   MsgBox ("Bulma işlemi tamamlandı.")
End Sub

 

[teo_64]

Merhaba

Çok teşekkürler beni büyük bir yükten kurtardınız

iyi çalışmalar

 

[Asri]

Merhaba

Çok teşekkürler beni büyük bir yükten kurtardınız

iyi çalışmalar

Programda küçük bir sorun var : )

ID lerin başına sadece bir sıfır ekliyor.
Eğer ID 000435 ise J kolonunda da 435 olarak görünüyor ise bulamayacaktır.

 

[teo_64]

Programda küçük bir sorun var : )

ID lerin başına sadece bir sıfır ekliyor.
Eğer ID 000435 ise J kolonunda da 435 olarak görünüyor ise bulamayacaktır.

O problem değil idler 5 karakter uzunluğunda o yüzden problem olmayacaktır şu an kullanıyorum teşekkürler

 

[tahsinanarat]

Altarnatif olsun

Arananlar Sheet1 in a sütununda olacak şekilde, Sheet2 nin b ve c sütunlarında arayıp, b sütununda bulduğunu d sütununa, c sütununda bulduğunu da d sütununa yazar. Dozyanız ekte

Option Explicit

Sub ADRES_ARA()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, BUL As Range, ADRES As String
    
    Application.ScreenUpdating = False

    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    
    On Error Resume Next
    S2.ShowAllData
    On Error GoTo 0
    
    S2.Range("d2:e" & Rows.Count).ClearContents
    
    For X = 2 To S1.Cells(Rows.Count, 1).End(3).Row
        Set BUL = S2.Range("b:C").Find(S1.Cells(X, 1), , , xlPart)
        If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
                BUL.Offset(0, 2) = S1.Cells(X, 1)
            Set BUL = S2.Range("b:C").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
    Next

    'S1.Range("A1").AutoFilter Field:=3, Criteria1:="X"

    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing

    Application.ScreenUpdating = True

    MsgBox "Bulma ve yazma işlemi tamamlanmıştır.", vbInformation
End Sub

 

[tahsinanarat]

Aynı sayfanın j sütunundan aramak istiyorsanız aşağıdaki kodları kullanın

Option Explicit

Sub ADRES_ARA()
    Dim S1 As Worksheet
    Dim X As Long, BUL As Range, ADRES As String
    
    Application.ScreenUpdating = False

    Set S1 = Sheets("Sheet1")
       
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    S1.Range("d2:e" & Rows.Count).ClearContents
    
    For X = 2 To S1.Cells(Rows.Count, 10).End(3).Row
        Set BUL = S1.Range("b:C").Find(S1.Cells(X, 10), , , xlPart)
        If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
                BUL.Offset(0, 2) = S1.Cells(X, 10)
            Set BUL = S1.Range("b:C").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
    Next

    'S1.Range("A1").AutoFilter Field:=3, Criteria1:="X"

    Set BUL = Nothing
    Set S1 = Nothing

    Application.ScreenUpdating = True

    MsgBox "Bulma ve yazma işlemi tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Yeni bir excel versiyonu çıkmış...

teo_64

Giriş: 14/10/2015
Şehir: uşak
Mesaj: 6
Excel Vers. ve Dili:
sdasdasdadadasd