kod hakkında

[aleysan]

selam arkadaşlar herekese kolay gelsin.

ekteki örnekteki kod

a kolonunu (tarihi)i düzenleyip d kolonuna,
b kolonunu (plaka)i düzenleyip e kolonuna,
c kolonunu (mıktar 1)ı düzenleyip f kolonuna aktarıyor.

benim isteğim d kolonuna mıktar 2 gelecek o yüzden
d1 hücresine yazdığım değeride aynı c kolonuna yaptığı işlemi
d ye de yapıp aktarması
bu durumda;

a kolonunu (tarihi)i düzenleyip e kolonuna,
b kolonunu (plaka)i düzenleyip f kolonuna,
c kolonunu (mıktar 1)ı düzenleyip g kolonuna,
d kolonunu (mıktar 2)ı düzenleyip h kolonuna aktarımasını
sağlayacak şekilde kodun düzenlenmesi konusunda yardımlarınızı bekliyorum.

 

[mancubus]

aşağıdaki gibi dener misiniz. yedek bir dosya üzerinde.
dosyanızda gizlenmiş sütunlar var. H da bunlardan biri.

Option Explicit
 
Sub KARAKTERLERİ_DÖNÜŞTÜR2()
    Dim X1 As Long, X2 As Integer, X3 As Integer, X4 As Integer, WF As WorksheetFunction
    Dim Gün As Byte, Ay As Byte, Yıl As Integer
    Dim Plaka As String, Veri_1 As String, Veri_2 As String, Veri_3 As String
    
    Set WF = WorksheetFunction
    
    Range("E:H").ClearContents
    Range("E:H").NumberFormat = "General"
    
    For X1 = 2 To Range("A65536").End(3).Row
        If Cells(X1, 1) <> "" Then
            If InStr(1, Cells(X1, 1), ".") > 0 Then
                Gün = Split(Cells(X1, 1), ".")(0)
                Ay = Split(Cells(X1, 1), ".")(1)
                Yıl = Split(Cells(X1, 1), ".")(2)
                Cells(X1, "E") = DateSerial(Yıl, Ay, Gün)
            ElseIf InStr(1, Cells(X1, 1), ",") > 0 Then
                Gün = Split(Cells(X1, 1), ",")(0)
                Ay = Split(Cells(X1, 1), ",")(1)
                Yıl = Split(Cells(X1, 1), ",")(2)
                Cells(X1, "E") = DateSerial(Yıl, Ay, Gün)
            Else
                Cells(X1, "E") = DateSerial(Mid(Cells(X1, 1), 7, 4), Mid(Cells(X1, 1), 4, 2), Mid(Cells(X1, 1), 1, 2))
            End If
        End If
        
        If Cells(X1, 2) <> "" Then
            Plaka = Evaluate("=UPPER(""" & Cells(X1, 2) & """)")
            Plaka = Replace(Plaka, " ", "")
            Plaka = Replace(Plaka, ",", "")
            Plaka = Replace(Plaka, ".", "")
            Plaka = Replace(Plaka, "/", "")
            Plaka = Replace(Plaka, "*", "")
            Plaka = Replace(Plaka, "-", "")
            Plaka = Replace(Plaka, "+", "")
            
            For X2 = 1 To Len(Plaka)
                If IsNumeric(Mid(Plaka, X2, 1)) Then
                    Veri_1 = Veri_1 & Mid(Plaka, X2, 1)
                Else
                    Exit For
                End If
            Next
            
            For X3 = 1 To Len(Plaka)
                If Not IsNumeric(Mid(Plaka, X3, 1)) Then
                    Veri_2 = Veri_2 & Mid(Plaka, X3, 1)
                End If
            Next
            
            For X4 = Len(Plaka) To 1 Step -1
                If IsNumeric(Mid(Plaka, X4, 1)) Then
                    Veri_3 = Veri_3 & Mid(Plaka, X4, 1)
                Else
                    Exit For
                End If
            Next
            Cells(X1, "F") = Veri_1 & " " & Veri_2 & " " & StrReverse(Veri_3)
            Veri_1 = ""
            Veri_2 = ""
            Veri_3 = ""
        End If
        
        If Cells(X1, 3) <> "" Then
            Cells(X1, "G") = Replace(Replace(Cells(X1, 3), ".", ""), ",", "")
            If Len(Cells(X1, "G")) < 5 Then Cells(X1, "G") = Cells(X1, "G") & WF.Rept(0, 5 - Len(Cells(X1, "G")))
        End If
        
        If Cells(X1, 4) <> "" Then
            Cells(X1, "H") = Replace(Replace(Cells(X1, 4), ".", ""), ",", "")
            If Len(Cells(X1, "H")) < 5 Then Cells(X1, "H") = Cells(X1, "H") & WF.Rept(0, 5 - Len(Cells(X1, "H")))
        End If

    Next
    
    Set WF = Nothing
    Range("A2:G" & Range("G65536").End(3).Row).Sort Key1:=Range("F2"), Key2:=Range("E2"), Key3:=Range("G2")
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[aleysan]

selam

hocam kodu denedim çalışıyor.
fakat biraz kullanalım hatalı bir durum olursa dönerim.
emek ve zamanınız için teşekkür ederim.
hoşçakalın.

 

[mancubus]

rica ederim. kolay gelsin.

ben dosyanızda denediğimde sorun olmadı.