• DİKKAT

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

Kod Yardımı

M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Merhabalar,


Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [V5:AD1000]) Is Nothing Then Exit Sub
      a = Target.Row
         Cells(a, "I") = "Chep "
For i = 22 To 30
    If Cells(a, i) > 0 Then
       sipariş = sipariş & Cells(a, "I") & "(" & Cells(4, i) & "  " & Cells(a, i) & "), - "
End If
Next
        Cells(a, "I") = sipariş
End Sub


Yukarıda ki koda yazı biçimi eklenir mi ? Font, boyut ve renk gibi.

Yardımlarınız için teşekkür ederim
 
Aşağıdaki şekilde yazabilirsiniz.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [V5:AD1000]) Is Nothing Then Exit Sub
      a = Target.Row
         Cells(a, "I") = "Chep "
For i = 22 To 30
    If Cells(a, i) > 0 Then
       sipariş = sipariş & Cells(a, "I") & "(" & Cells(4, i) & "  " & Cells(a, i) & "), - "
End If
Next
        Cells(a, "I") = sipariş
        With Cells(a, "I")
            .Font.Color = vbRed
            .Font.Bold = True
            .Font.Name = "Arial"
            .Font.Size = "14"
            
        End With
        
End Sub
 
Merhaba,

Örnek dosya da ki gibi yapılablir mi ?

Teşekkür ederim.
 

Ekli dosyalar

Kodları aşağıdaki şekilde revize edin.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [V5:BC1000]) Is Nothing Then Exit Sub
      a = Target.Row
         Cells(a, "I") = "GP-N "
For i = 22 To 30
    If Cells(a, i) > 0 Then
       Sipariş = Sipariş & Cells(a, "I") & "(" & Cells(4, i) & "-" & Cells(a, i) & "), - "
End If
Next
    Uzunluk1 = Len(Sipariş)
          
      a = Target.Row
         Cells(a, "I") = "Chep "
For i = 31 To 36
    If Cells(a, i) > 0 Then
       Sipariş = Sipariş & Cells(a, "I") & "(" & Cells(4, i) & "-" & Cells(a, i) & "), - "
End If
Next
        Uzunluk2 = Len(Sipariş) - Uzunluk1
       
      a = Target.Row
         Cells(a, "I") = "KP "
For i = 37 To 42
    If Cells(a, i) > 0 Then
       Sipariş = Sipariş & Cells(a, "I") & "(" & Cells(4, i) & "-" & Cells(a, i) & "), - "
End If
Next
    Uzunluk3 = Len(Sipariş) - Uzunluk2
        
        a = Target.Row
         Cells(a, "I") = "TP "
For i = 43 To 55
    If Cells(a, i) > 0 Then
       Sipariş = Sipariş & Cells(a, "I") & "(" & Cells(4, i) & "-" & Cells(a, i) & "), - "
End If
Next
    Uzunluk4 = Len(Sipariş) - Uzunluk3
        Cells(a, "I") = Sipariş
        With Cells(a, "I").Characters(Start:=1, Length:=Uzunluk1).Font
            .Color = vbRed
            .Bold = True
            .Name = "Arial"
            .Size = "10"
        End With
        With Cells(a, "I").Characters(Start:=Uzunluk1 + 1, Length:=Uzunluk2).Font
            .Color = vbYellow
            .Bold = True
            .Name = "Arial"
            .Size = "10"
        End With
         With Cells(a, "I").Characters(Start:=Uzunluk2 + 1, Length:=Uzunluk3).Font
            .Color = vbGreen
            .Bold = True
            .Name = "Arial"
            .Size = "10"
        End With
         With Cells(a, "I").Characters(Start:=Uzunluk3 + 1, Length:=Uzunluk4).Font
            .Color = vbBlue
            .Bold = True
            .Name = "Arial"
            .Size = "10"
        End With
End Sub
 
Günaydın,

Hocam, öncelikle uğraş ve emekleriniz için teşekkür ederim.
Verdiğiniz yeni kodları uyguladım ancak renkleri karıştırmakta.
 

Ekli dosyalar

Uzunluk3 ve uzunluk4 gibi değerler yanlış bulunuyor sanki. Dosyayı inceleyemedim henüz ama örneğin uzunluk3=len(sipariş) - uzunluk1-uzunluk2 olması gerekmez mi?
 
Sanırım aşağıdaki gibi olacak.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [V5:BC1000]) Is Nothing Then Exit Sub
      a = Target.Row
         Cells(a, "I") = "GP-N "
For i = 22 To 30
    If Cells(a, i) > 0 Then
       Sipariş = Sipariş & Cells(a, "I") & "(" & Cells(4, i) & "-" & Cells(a, i) & "), - "
End If
Next
    Bas1 = 1
    Bit1 = Len(Sipariş)
          
      a = Target.Row
         Cells(a, "I") = "Chep "
For i = 31 To 36
    If Cells(a, i) > 0 Then
       Sipariş = Sipariş & Cells(a, "I") & "(" & Cells(4, i) & "-" & Cells(a, i) & "), - "
End If
Next
    Bas2 = Bit1 + 1
    Bit2 = Len(Sipariş)
      a = Target.Row
         Cells(a, "I") = "KP "
For i = 37 To 42
    If Cells(a, i) > 0 Then
       Sipariş = Sipariş & Cells(a, "I") & "(" & Cells(4, i) & "-" & Cells(a, i) & "), - "
End If
Next
    Bas3 = Bit2 + 1
    Bit3 = Len(Sipariş)
        
        a = Target.Row
         Cells(a, "I") = "TP "
For i = 43 To 55
    If Cells(a, i) > 0 Then
       Sipariş = Sipariş & Cells(a, "I") & "(" & Cells(4, i) & "-" & Cells(a, i) & "), - "
End If
Next
    Bas4 = Bit3 + 1
    Bit4 = Len(Sipariş)
    
        Cells(a, "I") = Sipariş
        With Cells(a, "I").Characters(Start:=Bas1, Length:=Bit1).Font
            .Color = vbRed
            .Bold = True
            .Name = "Arial"
            .Size = "10"
        End With
        With Cells(a, "I").Characters(Start:=Bas2, Length:=Bit2).Font
            .Color = vbYellow
            .Bold = True
            .Name = "Arial"
            .Size = "10"
        End With
         With Cells(a, "I").Characters(Start:=Bas3, Length:=Bit3).Font
            .Color = vbGreen
            .Bold = True
            .Name = "Arial"
            .Size = "10"
        End With
         With Cells(a, "I").Characters(Start:=Bas4, Length:=Bit4).Font
            .Color = vbBlue
            .Bold = True
            .Name = "Arial"
            .Size = "10"
        End With
End Sub
 
Rica ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst