• DİKKAT

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

Bul komutuyla yapılabilir mi??

E

emre_oktay

Katılım
17 Ekim 2008
Mesajlar
33
Excel Vers. ve Dili
2007 tr
Ektedeki dosyada açıklamalı olarak var ama yapmak istediğim şu:

Yaklaşık 3000 kalem mal olan işyerinde stok numarası üretirken stok numarasından malzemenin ne olduğunu da anlayabilmek için malzemeleri gruplara ayırıp gruplardan harfleri çekmek istiyorum.

Ancak bazen aynı harfler denk geldiğinden istediğim harfleri kırmızı yazdım.
A-b-c-d- hücrelerinde kırmızı harfleri başka bir hücreye nasıl çekebilirim.
 

Ekli dosyalar

Merhaba Emre Bey,

Aşağıdaki kod ile kırmızı ile yazılmış karakterleri birleştirerek stok kodu oluşturabilirsiniz.

yanlız merak ediyorum, bu kadar çok ürünün stok kodunu oluşturmak için tek tek karakterleri nasıl kırmızı ile boyayacaksınız ? :)

Dosyayı ekledim; butona basmanız yeterli ...

Kod: 
Public Sub stok_kodu_olustur()
Dim karakter_sayisi As Integer
Dim kod_karakterleri As String
Dim satir_sayisi As Long
Dim toplam_urun As Integer

toplam_urun = Cells(Rows.Count, "A").End(xlUp).Row
For satir_sayisi = 2 To toplam_urun
    karakter_sayisi = Cells(satir_sayisi, 1).Characters.Count
    For i = 1 To karakter_sayisi
        If Cells(satir_sayisi, 1).Characters(i, 1).Font.ColorIndex = 3 Then
        Cells(satir_sayisi, 10).Value = Cells(satir_sayisi, 10).Value & Cells(satir_sayisi, 1).Characters(i, 1).Text
        End If
    Next
    karakter_sayisi = Cells(satir_sayisi, 2).Characters.Count
    For i = 1 To karakter_sayisi
        If Cells(satir_sayisi, 2).Characters(i, 1).Font.ColorIndex = 3 Then
        kod_karakterleri = kod_karakterleri & Cells(satir_sayisi, 2).Characters(i, 1).Text
        End If
    Next
    Cells(satir_sayisi, 10).Value = Cells(satir_sayisi, 10).Value & "-" & kod_karakterleri
    kod_karakterleri = ""
    karakter_sayisi = Cells(satir_sayisi, 3).Characters.Count
    For i = 1 To karakter_sayisi
        If Cells(satir_sayisi, 3).Characters(i, 1).Font.ColorIndex = 3 Then
        kod_karakterleri = kod_karakterleri & Cells(satir_sayisi, 3).Characters(i, 1).Text
        End If
    Next
    Cells(satir_sayisi, 10).Value = Cells(satir_sayisi, 10).Value & "-" & kod_karakterleri
    
    kod_karakterleri = ""
    karakter_sayisi = Cells(2, 4).Characters.Count
    For i = 1 To karakter_sayisi
        If Cells(satir_sayisi, 4).Characters(i, 1).Font.ColorIndex = 3 Then
        kod_karakterleri = kod_karakterleri & Cells(satir_sayisi, 4).Characters(i, 1).Text
        End If
    Next
    Cells(satir_sayisi, 10).Value = Cells(satir_sayisi, 10).Value & "-" & kod_karakterleri
Next
End Sub
 

Ekli dosyalar

Merhaba,

Alternatif olarak aşağıdaki koduda kullanabilirsiniz.

Daha önce özelden verdiğiniz bilgilere göre düzenlenmiştir.

Hücre boşsa "00" yazar.
Hücrede iki kelime yoksa ilk kelimenin soldan iki karakterini alır.

İsteğe göre bu koşullar arttırılabilir.

Not: Stok kodu oluşturmak için 3000 satırlık veriyi tek tek elle renklendirmenin bir mantığı yoktur. Bu tarz işlemleri makro kullanarak rahalıkla halledebilirsiniz.


Kod: 
Sub STOK_KODU_OLUŞTUR()
    Dim X As Long, Grup1 As String, Grup2 As String, Grup3 As String, Grup4 As String
    
    Application.ScreenUpdating = False
    
    Range("J2:J" & Rows.Count).ClearContents
    
    For X = 2 To Cells(Rows.Count, "E").End(3).Row
        Grup1 = ""
        Grup2 = ""
        Grup3 = ""
        Grup4 = ""
        
        If Cells(X, 1) = "" Then
            Grup1 = "00"
        Else
            Grup1 = Left(Cells(X, 1), 1)
        End If
        
        If Cells(X, 2) = "" Then
            Grup2 = "00"
        Else
            Grup2 = Left(Cells(X, 2), 2)
        End If
            
        If Cells(X, 3) = "" Then
            Grup3 = "00"
        Else
            If InStr(1, Cells(X, 3), " ") = 0 Then
                Grup3 = Left(Cells(X, 3), 2)
            Else
                Grup3 = Left(Split(Cells(X, 3), " ")(0), 1) & Left(Split(Cells(X, 3), " ")(1), 1)
            End If
        End If
        
        If Cells(X, 4) = "" Then
            Grup4 = "00"
        Else
            If InStr(1, Cells(X, 4), " ") = 0 Then
                Grup4 = Left(Cells(X, 4), 2)
            Else
                Grup4 = Left(Split(Cells(X, 4), " ")(0), 1) & Left(Split(Cells(X, 4), " ")(1), 1)
            End If
        End If
        
        Cells(X, "J") = Grup1 & "-" & Grup2 & "-" & Grup3 & "-" & Grup4
    Next
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Milady Meriç' Alıntı:
Merhaba Emre Bey,

Aşağıdaki kod ile kırmızı ile yazılmış karakterleri birleştirerek stok kodu oluşturabilirsiniz.

yanlız merak ediyorum, bu kadar çok ürünün stok kodunu oluşturmak için tek tek karakterleri nasıl kırmızı ile boyayacaksınız ? :)

Dosyayı ekledim; butona basmanız yeterli ...

Kod: 
Public Sub stok_kodu_olustur()
Dim karakter_sayisi As Integer
Dim kod_karakterleri As String
Dim satir_sayisi As Long
Dim toplam_urun As Integer

toplam_urun = Cells(Rows.Count, "A").End(xlUp).Row
For satir_sayisi = 2 To toplam_urun
    karakter_sayisi = Cells(satir_sayisi, 1).Characters.Count
    For i = 1 To karakter_sayisi
        If Cells(satir_sayisi, 1).Characters(i, 1).Font.ColorIndex = 3 Then
        Cells(satir_sayisi, 10).Value = Cells(satir_sayisi, 10).Value & Cells(satir_sayisi, 1).Characters(i, 1).Text
        End If
    Next
    karakter_sayisi = Cells(satir_sayisi, 2).Characters.Count
    For i = 1 To karakter_sayisi
        If Cells(satir_sayisi, 2).Characters(i, 1).Font.ColorIndex = 3 Then
        kod_karakterleri = kod_karakterleri & Cells(satir_sayisi, 2).Characters(i, 1).Text
        End If
    Next
    Cells(satir_sayisi, 10).Value = Cells(satir_sayisi, 10).Value & "-" & kod_karakterleri
    kod_karakterleri = ""
    karakter_sayisi = Cells(satir_sayisi, 3).Characters.Count
    For i = 1 To karakter_sayisi
        If Cells(satir_sayisi, 3).Characters(i, 1).Font.ColorIndex = 3 Then
        kod_karakterleri = kod_karakterleri & Cells(satir_sayisi, 3).Characters(i, 1).Text
        End If
    Next
    Cells(satir_sayisi, 10).Value = Cells(satir_sayisi, 10).Value & "-" & kod_karakterleri
    
    kod_karakterleri = ""
    karakter_sayisi = Cells(2, 4).Characters.Count
    For i = 1 To karakter_sayisi
        If Cells(satir_sayisi, 4).Characters(i, 1).Font.ColorIndex = 3 Then
        kod_karakterleri = kod_karakterleri & Cells(satir_sayisi, 4).Characters(i, 1).Text
        End If
    Next
    Cells(satir_sayisi, 10).Value = Cells(satir_sayisi, 10).Value & "-" & kod_karakterleri
Next
End Sub
Genişletmek için tıkla ...
Meriç Bey,
Öncelikle ilginize çok teşekkür ederim.
Malzemeler kalem bazında bakıldığında 3000 ve hatta biraz daha fazla ancak ana ve alt gruplar şeklinde 4 parçaya ayırdıktan sonra bu sayı kopyala yapıştır yaparak 400 civarına düşüyor. makro konusunda neredeyse hiç bilgim olmadığından böyle bir yöntem üretebildim ben ama siz makro sayesinde bana çok yardımcı oldunuz teşekkür eederim.
 
Korhan Ayhan' Alıntı:
Merhaba,

Alternatif olarak aşağıdaki koduda kullanabilirsiniz.

Daha önce özelden verdiğiniz bilgilere göre düzenlenmiştir.

Hücre boşsa "00" yazar.
Hücrede iki kelime yoksa ilk kelimenin soldan iki karakterini alır.

İsteğe göre bu koşullar arttırılabilir.

Not: Stok kodu oluşturmak için 3000 satırlık veriyi tek tek elle renklendirmenin bir mantığı yoktur. Bu tarz işlemleri makro kullanarak rahalıkla halledebilirsiniz.


Kod: 
Sub STOK_KODU_OLUŞTUR()
    Dim X As Long, Grup1 As String, Grup2 As String, Grup3 As String, Grup4 As String
    
    Application.ScreenUpdating = False
    
    Range("J2:J" & Rows.Count).ClearContents
    
    For X = 2 To Cells(Rows.Count, "E").End(3).Row
        Grup1 = ""
        Grup2 = ""
        Grup3 = ""
        Grup4 = ""
        
        If Cells(X, 1) = "" Then
            Grup1 = "00"
        Else
            Grup1 = Left(Cells(X, 1), 1)
        End If
        
        If Cells(X, 2) = "" Then
            Grup2 = "00"
        Else
            Grup2 = Left(Cells(X, 2), 2)
        End If
            
        If Cells(X, 3) = "" Then
            Grup3 = "00"
        Else
            If InStr(1, Cells(X, 3), " ") = 0 Then
                Grup3 = Left(Cells(X, 3), 2)
            Else
                Grup3 = Left(Split(Cells(X, 3), " ")(0), 1) & Left(Split(Cells(X, 3), " ")(1), 1)
            End If
        End If
        
        If Cells(X, 4) = "" Then
            Grup4 = "00"
        Else
            If InStr(1, Cells(X, 4), " ") = 0 Then
                Grup4 = Left(Cells(X, 4), 2)
            Else
                Grup4 = Left(Split(Cells(X, 4), " ")(0), 1) & Left(Split(Cells(X, 4), " ")(1), 1)
            End If
        End If
        
        Cells(X, "J") = Grup1 & "-" & Grup2 & "-" & Grup3 & "-" & Grup4
    Next
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...
Korhan haklısın ama makro bilgisi olmayınca tıkanıp kaldım aklımada başka bir şey gelmedi. Çok teşekkür ederim geçen gün özelden de bayağı uğraşmıştın tekrar saolasın
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst