Hücre icini ayirma

[Ömer]

Merhaba,

Çizgiden kastınızı tam olarak anlayamadım fakat ayırma işlemini aşağıdaki kodlarla yapabilirsiniz. Yada metni sütunlara dönüştür den kod elde ederek yazabilirsiniz. Metni sütunlara dönüştürü kullanmanızı tavsiye ederim. Makro kaydet ile dönüştürme seçeneğini deneyerek öğrenmeniz için o kısmı size bırakıp ben diğer yol ile çözeme gittim. Uygulayamazsanız o konuda da yardımcı olmaya çalışırım.

Sub Duzenle()
 
    Dim i As Long, deg1 As String, deg2, j As Integer, sut As Integer
 
    Application.ScreenUpdating = False
    Range(Cells(1, 3), Cells(Rows.Count, Columns.Count)).ClearContents
 
    On Error Resume Next
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        deg1 = Replace(Cells(i, "A") & " " & Cells(i, "B"), "-", " ")
        deg2 = Split(Trim(deg1), " ")
        sut = 3
        For j = 0 To UBound(deg2)
            If deg2(j) <> "" Then
                Cells(i, sut) = deg2(j)
                sut = sut + 1
            End If
        Next j
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

Not: Detaylı deneme yapmadım.

.

 

[mor45]

Merhaba,

Çizgiden kastınızı tam olarak anlayamadım fakat ayırma işlemini aşağıdaki kodlarla yapabilirsiniz. Yada metni sütunlara dönüştür den kod elde ederek yazabilirsiniz. Metni sütunlara dönüştürü kullanmanızı tavsiye ederim. Makro kaydet ile dönüştürme seçeneğini deneyerek öğrenmeniz için o kısmı size bırakıp ben diğer yol ile çözeme gittim. Uygulayamazsanız o konuda da yardımcı olmaya çalışırım.

Sub Duzenle()
 
    Dim i As Long, deg1 As String, deg2, j As Integer, sut As Integer
 
    Application.ScreenUpdating = False
    Range(Cells(1, 3), Cells(Rows.Count, Columns.Count)).ClearContents
 
    On Error Resume Next
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        deg1 = Replace(Cells(i, "A") & " " & Cells(i, "B"), "-", " ")
        deg2 = Split(Trim(deg1), " ")
        sut = 3
        For j = 0 To UBound(deg2)
            If deg2(j) <> "" Then
                Cells(i, sut) = deg2(j)
                sut = sut + 1
            End If
        Next j
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

Not: Detaylı deneme yapmadım.

.

Evet olmuş gözüküyor. Ama J sütunundan sonra olan L ili R sütunlarında başka veriler yazdırıyorum buralarda formüller var bunları siliyor
Yani L ile R sütunlardaki veriler hesaplama yaparken silmesini istemiyorum.
Şimdiden size teşekkür ediyorum.

 

[mor45]

Aşağıdaki kodu deneyiniz.

Sub VERILERI_AYIR()
    Dim Veri As Range, X As Integer, Data() As String, Sutun As Byte
    
    Range("C:Z").Clear
    
    For Each Veri In Range("A1:B" & Cells(Rows.Count, 1).End(3).Row)
        If Veri.Column = 1 Then Sutun = 3
        Data = Split(Replace(Veri.Text, "-", " "), " ")
        For X = 0 To UBound(Data)
            If Data(X) <> "" Then
                Cells(Veri.Row, Sutun) = Data(X)
                Sutun = Sutun + 1
            End If
        Next
    Next
        
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Denedim ama çalışıyor gibi gösteriyor ama bir türlü işlemi bitiremiyor. Sonram kilitlenip kalıyor.

 

[Ömer]

Parçalanacak veriler bu araya denk gelirse ne olacak?

Not: Aynı konuyla ilgili birden fazla başlık açmışsınız. Nedenini yazar mısınız. Eğer geçerli bir nedeni yoksa konuları birleştireceğim.
Aynı konuyla ilgili birden fazla konu başlığı açmamanızı rica ederim.

 

[Murat OSMA]

Evet Ömer Bey, aynı konu ve aynı dosya hk. iki farklı başlık açıldığı için ve dün akşam Korhan Bey bu konuya yanı verdiğinden ben de ilgilenmek istemedim.
Görüyorum ki konuya çözüm sunulmasına rağmen, sanki farklı bir konuymuş gibi devam ediliyor. Konuları birleştirip, devam edilecekse tek bir konuda devam etmek daha doğru olacaktır.

Saygılar

 

[mor45]

Parçalanacak veriler bu araya denk gelirse ne olacak?

Not: Aynı konuyla ilgili birden fazla başlık açmışsınız. Nedenini yazar mısınız. Eğer geçerli bir nedeni yoksa konuları birleştireceğim.
Aynı konuyla ilgili birden fazla konu başlığı açmamanızı rica ederim.

Sayın Ömer Bey ilginize teşekkür ediyorum.
Parçalanacak veriler bu araya gelecek kadar olacak fazlası veril olmayacak.

Evet iki konu çatım önceleri cevap alamamıştım; tam anlamıyla acaba konum vba oldu için başka yere yazmam gerektiğini düşündüm ondan yazdım.
Kusura bakmayın çözüm bulmak için uğraştım.
Yanlış bir şey oduysa özür diliyorum tüm arkadaşlardın.
Konuyu birleştirebilirsiniz.

L den sonraki verilerim olacağı için bunların silinmesini istemiyorum.

 

[Ömer]

Range(Cells(1, 3), Cells(Rows.Count, Columns.Count)).ClearContents

Yukarıdaki satırın yerine aşağıdaki satırı kullanın.

Range("C:J").ClearContents

.

 

[Korhan Ayhan]

Merhaba,

Ben önerdiğim kodu 15 nolu mesajınızda eklediğiniz dosyada denedim. 10 saniyede işlem tamamlandı. Sizin asıl dosyanızda ki durumu bilemem.

Birde aşağıdaki kodu deneyiniz. Veriler C-J sütunlarına listeleniyor.

Sub VERILERI_AYIR()
    Dim Veri As Range, X As Integer, Data() As String, Sutun As Byte
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Range("C:J").Clear
    
    For Each Veri In Range("A1:B" & Cells(Rows.Count, 1).End(3).Row)
        If Veri.Column = 1 Then Sutun = 3
        Data = Split(Replace(Veri.Text, "-", " "), " ")
        For X = 0 To UBound(Data)
            If Data(X) <> "" Then
                Cells(Veri.Row, Sutun) = Data(X)
                Sutun = Sutun + 1
            End If
        Next
    Next
        
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
                
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mor45]

Bu dosyamda birden çok sayfa var.
Ben bu modülü sadece (Der.Kad.Gös) olan sayfada çalıştırmak istiyorum.
Yaptınız gibi çalıştırdığımda işlem bir türlü bitmiyor. Kilitlenip kalıyor.

 

[Murat OSMA]

■ Alternatif;

Sub Metni_Sütunlara_Dönüştür()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets("Der.Kad.Gös")
        .Select
        .Columns("B:B").Cut
        .Columns("AB:AB").Select
        .Paste
        .Columns("A:A").TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
            "-", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
            TrailingMinusNumbers:=True
        .Columns("AB:AB").Cut
        .Columns("G:G").Select
        .Paste
        Selection.TextToColumns Destination:=.Range("G1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
            "-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
        .Cells.Select
        With Selection.Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        .Cells.Borders.LineStyle = 0
        .Cells.EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

 

[mor45]

Merhaba,

Ben önerdiğim kodu 15 nolu mesajınızda eklediğiniz dosyada denedim. 10 saniyede işlem tamamlandı. Sizin asıl dosyanızda ki durumu bilemem.

Birde aşağıdaki kodu deneyiniz. Veriler C-J sütunlarına listeleniyor.

Sub VERILERI_AYIR()
    Dim Veri As Range, X As Integer, Data() As String, Sutun As Byte
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Range("C:J").Clear
    
    For Each Veri In Range("A1:B" & Cells(Rows.Count, 1).End(3).Row)
        If Veri.Column = 1 Then Sutun = 3
        Data = Split(Replace(Veri.Text, "-", " "), " ")
        For X = 0 To UBound(Data)
            If Data(X) <> "" Then
                Cells(Veri.Row, Sutun) = Data(X)
                Sutun = Sutun + 1
            End If
        Next
    Next
        
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
                
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Sayın Korhan Ayhan bey
Sizin de dediğiniz gibi dosyamda çok sayfa mevcut bu modülü sadece ( Der.Kad.Gös) olan sayfamda uygulamak istiyorum.
Sizin dediğiniz 15 nolu mesajda ki dosyaya uygulandığında oluyor.

 

[mor45]

Sayın Murat Osman Bey
B sütunundaki veri tamamen kayboluyor G sütununa geliyor
Sırayla Önce A sütünü sonram B sütünü sırasıyla hücrelere atması gerekiyor.
Dosyam (xlsm ) uzantılı

 

[mor45]

Range(Cells(1, 3), Cells(Rows.Count, Columns.Count)).ClearContents

Yukarıdaki satırın yerine aşağıdaki satırı kullanın.

Range("C:J").ClearContents

.

Sayın Ömer bey dosya çalışıyor olmuş .
Tek sorun benim dosyamda birden çok sayfa var bu yaptınız modülü sadece (Der.Kad.Gös) sayfasında çalıştırmak istiyorum. Dosyamın uzantısı (xlsm) dir.

 

[Korhan Ayhan]

Bahsettiğiniz sayfanıza bir buton ekleyin. Daha sonra boş bir modüle kodu uygulayın.
Son olarak sayfa üzerindeki buton üzerinde sağ klik yapın ve MAKRO ATA seçeneğini seçin. Bu şekilde kodlar sadece butona tıkladığınızda ilgili sayfada çalışacaktır.

 

[mor45]

İşlemim olmuştur.
İlgilenen bütün arkadaşlara teşekkür ederim.