Hücre içindeki verileri ayırma

[denksal]

Kolay Gelsin
Sayfa 1 deki hücre içindeki verileri sayfa 2 deki ilgili satırlara Nasıl atarız arkadaşlar . Tşk ederim

plaka.xlsx

drive.google.com

 

[Korhan Ayhan]

Paylaştığınız kişisel bilgiler umarım gerçek değildir.

 

[denksal]

gercek degiller

 

[denksal]

Yardım edebilecek varmı?

 

[41AFU52]

Aşağıdaki videoda yer alan şekilde metni sütunlara dönüştür ile istediğiniz şekilde ayırıp, daha sonrasında birleştirmek istedikleriniz olursa birleştirebilirsiniz.

 

[Ömer]

Kolay Gelsin
Sayfa 1 deki hücre içindeki verileri sayfa 2 deki ilgili satırlara Nasıl atarız arkadaşlar . Tşk ederim

plaka.xlsx

drive.google.com

Merhaba,

İnceleyiniz.

İndir plaka Kopya

Dosyayı indir plaka Kopya

dosya.co

.

 

[denksal]

Ömer Bey Teşekkürler .Kısmen işim oldu .
Peki hücrede bulunan 2 .araç için nasıl ayırabiliz.
alt satıra atsa bile sıkıntı olmaz.

 

[Ömer]

Alt hücrelere dikkat etmemiştim.

Linki inceleyiniz.

İndir plaka

Dosyayı indir plaka

dosya.co

.

 

[denksal]

Kaldırılan Bölüm: /xl/vbaProject.bin bölümü. (Visual Basic for Applications (VBA))
Exceli açarken bunu yazıyor ve çalışmıyor sebebi nedir . ne yapmam gerekir?

 

[Ömer]

Linkte konuyla ilgili çözüm önerisi var dener misiniz.

Kaldırılan Bölüm: /xl/vbaProject.bin

Merhaba, Kaldırılan Bölüm: /xl/vbaProject.bin Böyle bir hatayı neden verir. Hiçbir makro çalışmıyor. Daha doğrusu VBA etkin değil. Excel tam sürüm mü yüklenmemiş acaba?

www.excel.web.tr

Ayrıca birde 97-2003 sürümü olarak ekliyorum dosyayı.

İndir plaka Kopya

Dosyayı indir plaka Kopya

dosya.co

 

[denksal]

Ömer Bey çok teşekkür ederim .
Keşke araçları yan yana yazacagımıza alt alta satıra atsaydık .. ellerine saglık

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Verileri_Ayirarak_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Son As Long, Veri As Variant, X As Long
    Dim Metin_A As Variant, Metin_B As Variant
    Dim Say As Long, Y As Byte, Z As Byte
    Dim Temizle As Variant, W As Byte
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S2.Range("A2:J" & S2.Rows.Count).Clear
    
    Temizle = Array("Cins : ", "Marka : ", "Model : ", "Renk : ", "Tip : ")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 2 Then Son = 2
    
    Veri = S1.Range("A1:E" & Son).Value
    
    ReDim Liste(1 To S1.Rows.Count, 1 To 10)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            Say = Say + 1
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Veri(X, 2)
            Liste(Say, 3) = Veri(X, 3)
            Liste(Say, 4) = Veri(X, 4)
            
            If InStr(1, Veri(X, 5), Chr(10) & Chr(10)) > 0 Then
                Metin_A = Split(Veri(X, 5), Chr(10) & Chr(10))
            
                For Y = LBound(Metin_A) To UBound(Metin_A)
                    Metin_B = Split(Metin_A(Y), Chr(10))
                    
                    Liste(Say, 1) = Veri(X, 1)
                    Liste(Say, 2) = Veri(X, 2)
                    Liste(Say, 3) = Veri(X, 3)
                    Liste(Say, 4) = Veri(X, 4)
                    
                    For Z = LBound(Metin_B) To UBound(Metin_B)
                        Liste(Say, Z + 5) = Metin_B(Z)
                        For W = LBound(Temizle) To UBound(Temizle)
                            Liste(Say, Z + 5) = Replace(Liste(Say, Z + 5), Temizle(W), "")
                        Next
                    Next
                    If Y < UBound(Metin_A) Then Say = Say + 1
                Next
            Else
                Metin_A = Split(Veri(X, 5), Chr(10))
                
                For Y = LBound(Metin_A) To UBound(Metin_A)
                    Liste(Say, Y + 5) = Metin_A(Y)
                    For W = LBound(Temizle) To UBound(Temizle)
                        Liste(Say, Y + 5) = Replace(Liste(Say, Y + 5), Temizle(W), "")
                    Next
                Next
            End If
        End If
    Next

    If Say > 0 Then
        S2.Range("A2").Resize(Say, 10) = Liste
        S2.Columns.AutoFit
        S2.Select
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[denksal]

Teşekkür edrim. Ellerinize saglık