Var olan kodu değiştirme.

sarman61 · 4 Eylül 2007

S.A

Bu kod üzerinde bir değişiklik yapmak istiyorum ama olmadı

Bu kod sayesinde a sutununda bulunan isimleri indexliyip numaralandırabiliyorum isimlere karşılık gelen numaralar ise sayfa 2 de hangi isme hangi numara verildiği şeklinde sıralıyor. Nitekim bazen bu numaralandırdığım isimler aynı satırda yan yana virgülle ayrılmış şeklinde 1 de fazla oluyor.

Konuyu aşağı tarafta örneklerle açıklamaya çalıştım.

Tablonun ilk hali

Örnek-1

--------A-------
1. HAKKI GÜLEN
2. ŞEHMUZ YİĞİT
3. AHMET ÖZTÜRK, MEHMET SAĞLAM
4. HÜSEYİN ŞEN

Bu kodu çalıştırdığımda isimleri tarayıp numaralandırabiliyorum. Sayfa 1 deki isimlerin yerine numara yazıyor sayfa 2 de de hangi ismin hangi numara olduğu yazıyordu.

Örnek-2
Sayfa-1

---------A---------
1-____2______
2-____5______
3-____1, 4____
4-____3______

Yukarıdaki şekilde olduğu gibi isimlerin yerine numara oluyor.

Sayfa 2 ise aşağıdaki gibi oluyordu.

--------A-------------|--------B--------
1-AHMET ÖZTÜRK_____|___1
2-HAKKI GÜLEN_______|___2
3-HÜSEYİN ŞEN_______|___3
4-MEHMET SAĞLAM____|__4
5-ŞEHMUZ YİĞİT______|___5

Şimdi ben kodu şu şekilde yapmak istiyordum. ÖRNEK-1 de A sutununda gözüken isimler gibi aynı tarz isimler
B sutununda da yazıyor.

Alıntı:
Örnek-3
Sayfa-1
--------A-------------------------|------------B-----------
1. HAKKI GÜLEN_________________| ADEM GÜRBÜZ
2. ŞEHMUZ YİĞİT________________| SEMİH AYTEKİN, FEHMİ KORU
3. AHMET ÖZTÜRK, MEHMET SAĞLAM| İCLAL AYDIN
4. HÜSEYİN ŞEN_________________| TAMER YEN, ŞERMİN AKTAŞ

Yukarıda yazan isimler yeni kod dan sonra aşağıdaki gibi olabilir mi?

Alıntı:

Sayfa-1
-------A------|------B-------
1-____4______|____1_____
2-____9______|____8, 3___
3-____2, 7____|____6_____
4-____5______|____11, 10_

Sayfa-2
---------A---------|--------B------
1-ADEM GÜRBÜZ___| 1
2-AHMET ÖZTÜRK___| 2
3-FEHMİ KORU______| 3
4-HAKKI GÜLEN_____| 4
5-HÜSEYİN ŞEN_____| 5
6-İCLAL AYDIN______| 6
7-MEHMET SAĞLAM__| 7
8-SEMİH AYTEKİN____| 8
9-ŞEHMUZ YİĞİT____| 9
10-ŞERMİN AKTAŞ_ | 10
11-TAMER YEN_____ | 11

Daha önceki code aşağıda. Bu yapmak isteidiğim işlemi yapmanan mümkünatı varmı dır varsa nasıldır. Yardımlarınız için şimdiden teşekkür ederim. Herkezlere iyi çalışmalar.

Kod:

Sub Indexle()
Application.ScreenUpdating = False
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Columns("A:b").ClearContents
s1.Select

For x = 2 To [A65536].End(3).Row
al = Cells(x, "A")
For Each d In Split(al, ",")
sat = sat + 1
s2.Cells(sat, 1) = Trim(d)
Next
Next x

s2.Select
Columns("A:b").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess

For x = [A65536].End(3).Row To 2 Step -1
If Cells(x, "a") = Cells(x - 1, "a") Then
Rows(x).Delete
End If
Next x

Recep İpek · 5 Eylül 2007

Yanlış anlamadıysam aşağıdaki kodlar işinize yarayabilir.

Kod:

Sub Indexle01()
On Error Resume Next
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
s2.Range("a2:b100").ClearContents
For Each veri In s1.Range("a2:b" & s1.Range("a65536").End(xlUp).Row)
    vv = Split(veri, ",")
    sat = s2.[a65536].End(3).Row + 1
    s2.Cells(sat, "a").Value = vv(0)
    s2.Cells(sat + 1, "a").Value = vv(1)
Next
'******************************************
 s2.Range("a2:a" & s2.Range("a65536").End(xlUp).Row).Sort Key1:=s2.Range("A2"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
With CreateObject("scripting.dictionary")
    For Each r In s2.Range("a2:a" & s2.Range("a65536").End(xlUp).Row)
        n = n + 1
        If Not .exists(r.Value) Then .Add r.Value, n
    Next
        s2.Range("a2:b" & s2.Range("a65536").End(xlUp).Row).ClearContents
        s2.Range("a2").Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)
        s2.Range("b2").Resize(.Count, 1) = WorksheetFunction.Transpose(.items)
End With
'******************************************
For Each bul In s2.Range("a2:a" & s2.Range("a65536").End(xlUp).Row)
    For Each deg In s1.Range("a2:b" & s1.Range("a65536").End(xlUp).Row)
        vv = Split(deg, ",")
        If vv(0) = bul Then
        s1.Cells(deg.Row, deg.Column).Replace What:=vv(0), Replacement:=bul.Offset(0, 1).Value, LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
       End If
       If vv(1) = bul Then
        s1.Cells(deg.Row, deg.Column).Replace What:=vv(1), Replacement:=bul.Offset(0, 1).Value, LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
       End If
    Next
Next
'******************************************
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

sarman61 · 5 Eylül 2007

Hocam verdiğin kod işe yarıyor ama tam olarak işimi görmedi. Mahsuru yoksa bu eksikliği giderme şansımız varmı. Bu isimler bazen virgülle ayrılmış şekilde yan yana 5 tane olabiliyor. Senin veridiğin kod ise yan yana yazan 2 isme numara veriyor 3. ye ise numara vermiyor.

Benim numaralandırmak istediğim isimler ekteki dosyada. Yardımın için çok teşekkür ederim.

Recep İpek · 5 Eylül 2007

Aşağıdaki kodları deneyebilirsiniz.

Verileriniz çok fazla olduğu için biraz beklemeniz gerekebilir.Ayrıca bu isimleri teke indirdiğimiz zaman 65536 sınırını aşmaktadır.Size tavsiyem parça parça bu kodu çalıştırmanızdır.

Müsait olduğumda ise makroyu daha hızlı hale getirmek için üzerinde çalışacağım.

Not:Üstteki ekli dosya revize edilmiştir.

Kod:

Sub Indexle01()
On Error Resume Next
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("a2:b100").ClearContents
 son = 2
    For i = 2 To s1.Cells(65536, 1).End(xlUp).Row
        a = WorksheetFunction.Transpose(Split(Cells(i, 1), ","))
        boyut = UBound(a)
        s2.Cells(son, "a").Resize(boyut) = a
        son = son + boyut
    Next i
    For i = 2 To s1.Cells(65536, 2).End(xlUp).Row
        a = WorksheetFunction.Transpose(Split(Cells(i, 2), ","))
        boyut = UBound(a)
        s2.Cells(son, "a").Resize(boyut) = a
        son = son + boyut
    Next i
    
'******************************************
 s2.Range("a2:a" & s2.Range("a65536").End(xlUp).Row).Sort Key1:=s2.Range("A2"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
With CreateObject("scripting.dictionary")
    For Each r In s2.Range("a2:a" & s2.Range("a65536").End(xlUp).Row)
        n = n + 1
        If Not .exists(r.Value) Then .Add r.Value, n
    Next
        s2.Range("a2:b" & s2.Range("a65536").End(xlUp).Row).ClearContents
        s2.Range("a2").Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)
        s2.Range("b2").Resize(.Count, 1) = WorksheetFunction.Transpose(.items)
End With
'******************************************
devam:
For Each bul In s2.Range("a2:a" & s2.Range("a65536").End(xlUp).Row)
    For Each deg In s1.Range("a2:b" & s1.Range("a65536").End(xlUp).Row)
    If deg = "" Then GoTo devam
        vv = Split(deg, ",")
              For j = 0 To 10
                If vv(j) = bul Then
                s1.Cells(deg.Row, deg.Column).Replace What:=vv(j), Replacement:=bul.Offset(0, 1).Value, LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
            End If
        Next j
    Next
Next
'******************************************
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

sarman61 · 5 Eylül 2007

ripek kardeşim peki şöyle birşey yapabilirmiyiz bu sayfa 2 deki yere ben hangi isme hangi numaranın geleceğini yazsam. Kod sayesinde sayfa1 deki isimleri sayfa 2 deki numaralara göre numaralandırsa. Kusura bakma seninde başını ağırttım. Yardımın için çok teşekkür ederim Allah razı olsun.

Recep İpek · 5 Eylül 2007

O zaman ilgili kodların sadece 3. bölümünü kullanmanız yeterlidir.

Kod:

Sub Indexle01()
On Error Resume Next
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'******************************************
devam:
For Each bul In s2.Range("a2:a" & s2.Range("a65536").End(xlUp).Row)
    For Each deg In s1.Range("a2:b" & s1.Range("a65536").End(xlUp).Row)
    If deg = "" Then GoTo devam
        vv = Split(deg, ",")
              For j = 0 To 10
                If vv(j) = bul Then
                s1.Cells(deg.Row, deg.Column).Replace What:=vv(j), Replacement:=bul.Offset(0, 1).Value, LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
            End If
        Next j
    Next
Next
'******************************************
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

Var olan kodu de&#287;i&#351;tirme.

sarman61

Recep İpek

sarman61

Recep İpek

sarman61

Recep İpek

Var olan kodu değiştirme.