• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

excel macro isteğe bağlı koşulları aktaramıyorum.

A

aybekcan

Katılım
16 Kasım 2017
Mesajlar
70
Excel Vers. ve Dili
2010 türkçe
merhabalar.
ben sadece sayılar ile rakamlar ve sayılar bulunan bir metinden rakamları belli bir koşula bağlı olarak farklı hücrelere kopyalamaya çılışıyorum.örneğin
KSMN 181040Z 1812/1918 22015KT 9999 SCT040 TEMPO 1815/1818 24017G28KT BECMG 1815/1818 -SHRA BKN035 BKN100 PROB40 TEMPO 1819/1823 24015G25KT 4000 SHRA FEW017CB BKN025 BECMG 1823/1902 01012KT SCT012 BKN025 BECMG 1906/1909 2000 BR SCT035 BKN100=
bu metinden kırmızı işaretli olan sadece rakamdan ibaret bölümlerini alıp belli hücrelere kopyalamak iştiyorum ama bu rakamların yeri her zaman sabit değil.
ben şöyle bir macro yazdım ama çalışmadı,nedenini açıklayabilirseniz sevinirim.şimdiden teşekkür ederim.
Sub olay()
Dim i As Integer
For i = 4 To 22
Worksheets("sayfa1").Activate
Set aralık = Worksheets("Sayfa1").Cells(2, i)
If aralık.Value < 9999 Then
aralık.Select
Worksheets("sayfa2").Activate
Worksheets("Sayfa2").Range("a1").PasteSpecial
Application.CutCopyMode = False
ElseIf aralık.Value < 9999 And aralık.Value >= 8000 Then
aralık.Select
Selection.Copy
Worksheets("sayfa2").Activate
Worksheets("Sayfa2").Range("a2").PasteSpecial
Application.CutCopyMode = False

ElseIf aralık.Value < 8000 And aralık.Value >= 5000 Then
aralık.Select
Selection.Copy
Worksheets("sayfa2").Activate
Worksheets("Sayfa2").Range("a3").PasteSpecial
Application.CutCopyMode = False

ElseIf aralık.Value < 5000 And aralık.Value >= 3700 Then
aralık.Select
Selection.Copy
Worksheets("sayfa2").Activate
Worksheets("Sayfa2").Range("a4").PasteSpecial
Application.CutCopyMode = False

ElseIf aralık.Value < 3700 And aralık.Value >= 1600 Then
aralık.Select
Selection.Copy
Worksheets("sayfa2").Activate
Worksheets("Sayfa2").Range("a5").PasteSpecial
Application.CutCopyMode = False

ElseIf aralık.Value < 1600 And aralık.Value >= 800 Then
aralık.Select
Selection.Copy
Worksheets("sayfa2").Activate
Worksheets("Sayfa2").Range("a6").PasteSpecial
Application.CutCopyMode = False

ElseIf aralık.Value < 800 And aralık.Value >= 0 Then
aralık.Select
Selection.Copy
Worksheets("sayfa2").Activate
Worksheets("Sayfa2").Range("a7").PasteSpecial
Application.CutCopyMode = False


Exit For
End If
Next i
End Sub
 
Evet çok teşekkür ederim.Ben macro yazmayı yeni yeni öğrenmeye çalışıyorum da,benim yazdığım macroda sorun ne acaba?neden çalışmıyor? birde bu işlemi yaklaşık 30 metin için yapmam gerekiyor.sizin yazdığınız kodu "end sub" dan önce farklı satırlar için uyarlayıp eklesem hepsini otomatik olarak yapar mı?
 
Merhaba
Sizin yukarıdaki yazdığınız kodda "Set aralık = Worksheets("Sayfa1").Cells(2, i)" "aralık" hücrenin içeriğini (aralarındaki boşluklarda bir karekterdir) tek bir değer olarak tanımlar.
Kelimeleri ve sayıları belli bir kritere göre ayırıp bakmak gerekir örnekteki kodlarda "split(hcr, " ")"
ile aralarıdaki boşluklara göre ayırarak kelime veya sayıları tek tek kontrol eder.
Aynı satırda (sizin kodlara göre "D" sütunundan başlayarak "V" sütuna kadar gidecekse kırmızı bölümleri ekeleyerek yapabilirsiniz
ama diğerlerinide "sayfa2" "a1:a7" aralığına yazacak/değiştirecektir.
Açıklamalı bir örnek dosya eklerseniz www.dosya.tc
Kod: 
[SIZE="2"]Sub olay()
Dim i As Integer, s1 As Worksheet, s2 As Worksheet, hcr As Range, aralık
Dim x As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
[COLOR="Red"]For x = 4 To 22[/COLOR]
Set hcr = s1.Cells(2, x)
For i = 0 To UBound(Split(hcr, " "))
aralık = Split(hcr, " ")(i)
If IsNumeric(aralık) = True Then
[COLOR="Blue"]'...
'.. kodlar
'...
'......[/COLOR]
End If: End If
Next i: [COLOR="Red"]Next x[/COLOR][/SIZE]

veya belli bir aralık içinde şöyle olabilir

Kod: 
[SIZE="2"]For Each x In Range("A1:D10")
Set hcr = x.value
[/SIZE]
 
Hocam ilginiz için çok teşekkür ederim.sizler sayesinde bir şeyler öğreniyoruz.kitaplar bir yere kadar yardım ediyor ama iş kod yazmaya gelince sizler gibi ustalardan öğrendiğimizi kitaplardan öğrenemiyoruz.Hocam sizin yazdığınız kodu "end sub" dan önce farklı satırlar için uyarlayıp eklesem hepsini otomatik olarak yapar mı?Bu işlemleri yüklediğim dosya üzerinden yapabilir misiniz? her "=" ifadesine kadar olanı bir metin olarak değerlendiriyoruz.birde yaklaşık 30 metin kadar bir işlemi yapmam gerekiyor.Hocam sizi çok meşgul etmek istemiyorum ama
"KSMN 181040Z 1812/1918 22015KT 9999 SCT040 TEMPO 1815/1818 24017G28KT BECMG 1815/1818 -SHRA BKN035 BKN100 PROB40 TEMPO 1819/1823 24015G25KT 4000 SHRA FEW017CB BKN025 BECMG 1823/1902 01012KT SCT012 BKN025 BECMG 1906/1909 2000 BR SCT035 BKN100="bu dayfadaki metnin örneklerinden,burada da aynı renk olan rakam ve sadece rakamların önündeki "1812/1918" gibi ifadeleri,yine aynı renk olan rakamların yanınındaki hücreye nasıl yazdırabiliriz. örnek:
9999 1812/1918
4000 1819/1823
2000 1906/1909 gibi.
http://www.dosya.tc/server12/pkb3b9/TTT.xlsx.html
 
Son düzenleme:
çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst