Hücre içindeki verileri Sutunlara Ayırma

[yasin85]

Merhaba Arkadaşlar,

Aynı hüçre içersinde (/) ile ayrılmış kodlar var bu kodları Excel'de A:A dan başlayarak sonrasına (/) lı olan kodları yan yana sutunlara ayırmak istiyorum fakat metin olarak ayırmam gerek aşağıdaki makroyu kullanarak işlemi yaptığımda makro sapıtıyor bazı kalemlerde var hüçre içersinde olmayan kodlarıda getiriyor..
yardımlarınızı bekliyorum..

İlgili dosyayı ekledim..

Sub Ayikla()
col = ActiveCell.Column
For i = 2 To 65000
Cells(i, col).Select
If InStr(Cells(i, col).Value, "/") > 0 Then
Metin = Cells(i, col).Value
Z = 0
For j = 1 To Len(Metin)
If Mid(Metin, j, 1) = "/" Then
Z = Z + 1
End If
Next j
ReDim y(Z + 1)
c = 0
For k = 1 To Len(Metin)
If Mid(Metin, k, 1) <> "/" Then
x = x & Mid(Metin, k, 1)
End If
If Mid(Metin, k, 1) = "/" Then
y(c) = x
c = c + 1
x = ""
End If
Next k
y(Z) = x
Cells(i, 26 + c).Select
For k = 0 To UBound
Cells(i, 27 + k).Value = "'" & y(k)
Next k
Else
Cells(i, 27).Value = "'" & Cells(i, col).Value
End If
Next i
End Sub

 

[yasin85]

yardımcı ola bilecek kimse yok mu arkadaşlar..

 

[Ömer]

Merhaba,

Verilerin ayrılmamış halini ekleyip soruyu dosya içersinde açıklarmısınız.

.

 

[yasin85]

Merhaba Ömer Bey,

İlk dört sıradan OEM1 ve OEM2 alanlarında ( / ) ile ayrılması gereken durumu belirttim yanlız metin olması gerekli çünki kodların başlarında 0 ile başlayanlar var onların kaybolmaması gerekli..

 

[yasin85]

http://hizliresimyukle.com/showpic-354389/oem_ayirma_2.jpg

 

[Ömer]

Verileri ayrımadan önceki dosyanızı excel formatında eklemeniz mümkün mü. En azından bu şekilde dosya üzerinde çalışarak çözüm önermem daha kolay olur.

 

[yasin85]

Verileri ayrımadan önceki dosyanızı excel formatında eklemeniz mümkün mü. En azından bu şekilde dosya üzerinde çalışarak çözüm önermem daha kolay olur.

eklemeye çalıştım umarım olmuştur..

 

[yasin85]

Verileri ayrımadan önceki dosyanızı excel formatında eklemeniz mümkün mü. En azından bu şekilde dosya üzerinde çalışarak çözüm önermem daha kolay olur.

orjinal hali

 

[Ömer]

Yasin bey,

Dosyadaki veriler sütunlara ayrılmamış halimi yoksa ayrımayı denedikten sonra oluşan halimi? Eğer ayırma işlemi sonrası haliyse, denenmemiş yani dosyanın orjinal halini eklermisiniz. Ekledikten sonra sorunu detaylı açıklarmısınız.

Eğer orjinal haliyse, bu dosya üzerinden istediğiniz nedir? Sorunu detaylı açıklarmısınız.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

AA sütunundan itibaren listeleme yapar.

Sub AKTAR()
    Dim X As Long, Y As Byte, Z As Byte, Satir As Long, Sutun As Byte, Data As Variant
    
    Application.ScreenUpdating = False
    
    Zaman = Timer
    
    Range("AA:IV").Clear
    Range("AA:IV").NumberFormat = "@"
    
    Satir = 2
    Sutun = 27
    
    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        For Y = 2 To Cells(X, "K").End(1).Column
            If Cells(X, Y) <> "" Then
                If InStr(1, Cells(X, Y), "/") = 0 Then
                    Cells(Satir, Sutun) = Cells(X, Y)
                    Sutun = Sutun + 1
                Else
                    Data = Split(Cells(X, Y), "/")
                    For Z = 0 To UBound(Data)
                        Cells(Satir, Sutun) = Data(Z)
                        Sutun = Sutun + 1
                    Next
                End If
            End If
        Next
        Satir = Satir + 1
        Sutun = 27
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
          "İşlem süresi ; " & Format((Timer - Zaman) / 60 / 60 / 24, "hh:mm:ss:ms"), vbInformation
End Sub

 

[yasin85]

Merhaba,

Aşağıdaki kodu deneyiniz.

AA sütunundan itibaren listeleme yapar.

Sub AKTAR()
    Dim X As Long, Y As Byte, Z As Byte, Satir As Long, Sutun As Byte, Data As Variant
    
    Application.ScreenUpdating = False
    
    Zaman = Timer
    
    Range("AA:IV").Clear
    Range("AA:IV").NumberFormat = "@"
    
    Satir = 2
    Sutun = 27
    
    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        For Y = 2 To Cells(X, "K").End(1).Column
            If Cells(X, Y) <> "" Then
                If InStr(1, Cells(X, Y), "/") = 0 Then
                    Cells(Satir, Sutun) = Cells(X, Y)
                    Sutun = Sutun + 1
                Else
                    Data = Split(Cells(X, Y), "/")
                    For Z = 0 To UBound(Data)
                        Cells(Satir, Sutun) = Data(Z)
                        Sutun = Sutun + 1
                    Next
                End If
            End If
        Next
        Satir = Satir + 1
        Sutun = 27
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
          "İşlem süresi ; " & Format((Timer - Zaman) / 60 / 60 / 24, "hh:mm:ss:ms"), vbInformation
End Sub

Korhan Bey,

Makroyu çalıştırmam için ne yapmam gerekli hangi hücrede çalıştırmam gerekli çünki her hangi bir alanda deniyorum çalışmıyor bekliyor yardımlarınızı bekliyorum..

 

[yasin85]

Sorun çözüldü makroyu yaptılar aşağıdaki gibidir..


Function getSat(RowNo As Integer, ColNo As Integer) As Double
Dim SatNo As Double
Cells(RowNo, ColNo).Select
Selection.End(xlDown).Select
SatNo = ActiveCell.Row
getSat = CInt(SatNo)
End Function

Function getSut(RowNo As Integer, ColNo As Integer) As Double
Dim SutNo As Double
Cells(RowNo, ColNo).Select
Selection.End(xlToRight).Select
SutNo = ActiveCell.Column
getSut = CInt(SutNo)
End Function


Sub Ayikla()
Dim i As Double
Dim sat As Double

col = ActiveCell.Column
'sat = getSat(1, 2)
For i = 2 To 52417
Cells(i, col).Select
If InStr(Cells(i, col).Value, "/") > 0 Then
Metin = Cells(i, col).Value
Z = 0
For j = 1 To Len(Metin)
If Mid(Metin, j, 1) = "/" Then
Z = Z + 1
End If
Next j
ReDim y(Z + 1)
c = 0
x = ""
For k = 1 To Len(Metin)
If Mid(Metin, k, 1) <> "/" Then
x = x & Mid(Metin, k, 1)
End If
If Mid(Metin, k, 1) = "/" Then
y(c) = x
c = c + 1
x = ""
End If
Next k
y(Z) = x
Cells(i, 26 + c).Select
For k = 0 To UBound
Cells(i, 27 + k).Value = "'" & y(k)
Next k
Else
Cells(i, 27).Value = "'" & Cells(i, col).Value
End If
Next i
End Sub