Makroyla başlığa göre hücre doldurma

[as2380]

Arkadaşlar ekte gönderdiğim tablonun orjinal halinde C1 hücresinde şu beş çeşit başlıktan biri var,bunlar;
2007-08-03 Tarihli LON Ham Mizan Bilgileri
2007-08-03 Tarihli NEWYO Ham Mizan Bilgileri
2007-08-03 Tarihli SOFIA BU Ham Mizan Bilgileri
2007-08-03 Tarihli TBILISI G Ham Mizan Bilgileri
2007-08-03 Tarihli SKOPJE MAC Ham Mizan Bilgileri


Bu başlığın içindeki şube adına göre(LON,NEWYP,SOFIA BU,TBILISI G,SKOPJE MAC) tarihler değişebiliyor ama hepsinde şube adları 20.karakterden itibaren yazılıyor,buna göre bişey yapılabilir belki
ve benim istediğim bu şube adlarına göre ekteki tablonun istenilen hal sayfasındaki gibi A ve B sütunlarına 3.satırdan en sona kadar olmak üzere

1470 LONDRA
1469 NEWYORK
1679 SOFYA
1766 TİFLİS
1696 ÜSKÜP

değerlerinin verilmesi,yani başlık londraysa hepsi 1470 LONDRA olmasını sağlayacak bir makro

Yardımlarınız için teşekkürler...

 

[omerceri]

orjinaline benzer bir örnek dosya eklersen, birde orjinal dosya excel dosyası mı? txt gibi bir metin dosyası mı?

 

[as2380]

Eklediğim dosyayı açamadınız mı acaba?orda orjinali de var benim ulaşmak istediğim hali de var
Ayrıca excel dosyası o da,açılmıyor mu?

 

[Korhan Ayhan]

Selamlar,

Sn. veyselemre beyin size önerdiği kodu aşağıdaki şekilde değiştirip denermisiniz.

Sub Sil()
Dim rForDelete As Range
Dim c As Range
    With Sheets("Sayfa1")
        For Each c In Range(.[a3], .[a65536].End(3))
            If (Not c.Value Like "1*" And Not c.Value Like "9*") Or _
               WorksheetFunction.CountIf(Range(c.Offset(1), c.End(xlDown)), c.Value & "*") Then
                If Not rForDelete Is Nothing Then
                    Set rForDelete = Union(rForDelete, c)
                Else
                    Set rForDelete = c
                End If
            End If
        Next
        If Not rForDelete Is Nothing Then rForDelete.EntireRow.Delete (xlUp)
        .Columns("A:B").Insert Shift:=xlToRight
        .Columns("H:I").Cut
        .Columns("D:E").Select
        .Paste
    End With
    Kriter = Split([C1], " ")
    For X = 3 To [C65536].End(3).Row
    If Kriter(2) = "LON" Then
    Cells(X, 1) = 1470
    Cells(X, 2) = "LONDRA"
    ElseIf Kriter(2) = "NEWYO" Then
    Cells(X, 1) = 1469
    Cells(X, 2) = "NEWYORK"
    ElseIf Kriter(2) = "SOFIA" Then
    Cells(X, 1) = 1679
    Cells(X, 2) = "SOFYA"
    ElseIf Kriter(2) = "TBILISI" Then
    Cells(X, 1) = 1766
    Cells(X, 2) = "TİFLİS"
    ElseIf Kriter(2) = "SKOPJE" Then
    Cells(X, 1) = 1696
    Cells(X, 2) = "ÜSKÜP"
    End If
    Next
End Sub

 

[veyselemre]

Sub dene()
    bul = Split([c1], " ")(2)
    a = Array(Array(1470, "LONDRA"), Array(1469, "NEWYORK"), Array(1679, "SOFYA"), Array(1766, "TİFLİS"), Array(1696, "ÜSKÜP"))
    For x = 0 To UBound(a)
        If (a(x)(1) Like bul & "*") Then
            Range([a3], [c65536].End(3).Offset(, -1)).Value = a(x)
            Exit Sub
        End If
    Next x
End Sub

 

[goklerhakimi]

Merhaba,

aşağıdaki kodlar işe yarar mı acaba?

Sub sehirler()

'
'2007-08-03 Tarihli LON Ham Mizan Bilgileri
'2007-08-03 Tarihli NEWYO Ham Mizan Bilgileri
'2007-08-03 Tarihli SOFIA BU Ham Mizan Bilgileri
'2007-08-03 Tarihli TBILISI G Ham Mizan Bilgileri
'2007-08-03 Tarihli SKOPJE MAC Ham Mizan Bilgileri
'
'
'1470 LONDRA
'1469 NEWYORK
'1679 SOFYA
'1766 TİFLİS
'1696 ÜSKÜP
Dim sehir, sehir_kodu As String

baslik = Cells(1, 3)
satir = 3
While Cells(satir, 3) <> ""
satir = satir + 1
Wend
sehir_kisa = Mid(baslik, 20, 2)

If sehir_kisa = "LO" Then
sehir = "LONDRA"
sehir_kodu = 1470
ElseIf sehir_kisa = "NE" Then
sehir = "NEWYORK"
sehir_kodu = 1469
ElseIf sehir_kisa = "SO" Then
sehir = "SOFYA"
sehir_kodu = 1679
ElseIf sehir_kisa = "Tb" Then
sehir = "T&#304;FL&#304;S"
sehir_kodu = 1766
ElseIf sehir_kisa = "SK" Then
sehir = "&#220;SK&#220;P"
sehir_kodu = 1696
End If


For i = 3 To satir - 1
Cells(i, 1) = sehir_kodu
Cells(i, 2) = sehir
Next i

End Sub

 

[veyselemre]

Şehir isimlerinin düzenli olmadığını fark ettim bu şekilde kullanabilirsiniz.

Sub dene()
    bul = Split([c1], " ")(2)
    b = Array("LON", "NEWYO", "SOFIA", "TBILISI", "SKOPJE")
    a = Array(Array(1470, "LONDRA"), Array(1469, "NEWYORK"), Array(1679, "SOFYA"), Array(1766, "TİFLİS"), Array(1696, "ÜSKÜP"))
    For x = 0 To UBound(b)
        If (b(x) Like bul & "*") Then
            Range([a3], [c65536].End(3).Offset(, -1)).Value = a(x)
            Exit Sub
        End If
    Next x
End Sub

 

[as2380]

Çok TeŞekkÜr Ederİm, Ellerİnİze SaĞlik ArkadaŞlar...