Belli değerleri makro ile bölme

A

ADER_34

Katılım
2 Haziran 2015
Mesajlar
312
Excel Vers. ve Dili
2010
Merhaba arkadaşlar benim sorunum excelde tek hücrede iç içe yazılmış Https ile başlayan internet adrelerini bölüp alt alta almak
örnek: Https// trendyol............... Https//hepsiburada.......https// böyle uzayıp gidiyor..
Bu adresler tek A1 Sütununda sonuç A1,A2,A3,A4 gibi alt satırlara ayırmak istiyorum
teşekkürler

 
 
V

volki_112

Altın Üye
Katılım
29 Eylül 2023
Mesajlar
681
Excel Vers. ve Dili
2019 Türkçe
Altın Üyelik Bitiş Tarihi
13-12-2029
ADER_34' Alıntı:
Merhaba arkadaşlar benim sorunum excelde tek hücrede iç içe yazılmış Https ile başlayan internet adrelerini bölüp alt alta almak
örnek: Https// trendyol............... Https//hepsiburada.......https// böyle uzayıp gidiyor..
Bu adresler tek A1 Sütununda sonuç A1,A2,A3,A4 gibi alt satırlara ayırmak istiyorum
teşekkürler
 
Genişletmek için tıkla ...
istediğiniz kod
Kod: 
Sub HttpAdresleriniBolVeAltSatiraYaz()

    Dim kaynakHucre As Range
    Dim hedefBaslangicHucre As Range
    Dim kaynakMetin As String
    Dim satirOfseti As Long
    
    Dim RegEx As Object
    Dim Matches As Object
    Dim Match As Object
    Dim i As Long

    ' Kullanıcıdan kaynak hücreyi seçmesini iste
    On Error Resume Next
    Set kaynakHucre = Application.InputBox("Lütfen 'Https' veya 'Http' ile başlayan adresleri içeren TEK BİR hücreyi seçin:", "Kaynak Hücre Seçimi", Type:=8)
    On Error GoTo 0

    If kaynakHucre Is Nothing Then
        MsgBox "Hücre seçilmedi, işlem iptal edildi.", vbInformation
        Exit Sub
    End If

    If kaynakHucre.Cells.CountLarge > 1 Then
        MsgBox "Lütfen sadece tek bir hücre seçin.", vbExclamation
        Exit Sub
    End If

    kaynakMetin = kaynakHucre.Value
    Set hedefBaslangicHucre = kaynakHucre ' Yazma işlemi bu hücreye göre ofsetlenecek

    ' Düzenli ifade (Regular Expression) nesnesini oluştur
    Set RegEx = CreateObject("VBScript.RegExp")
    With RegEx
        .Global = True      ' Metindeki tüm eşleşmeleri bul
        .IgnoreCase = True  ' Büyük/küçük harf duyarsız arama (http, Http, HTTP vb.)
        .Pattern = "https?://" ' "http://" veya "https://" ile başlayan kısımları bul
    End With

    Set Matches = RegEx.Execute(kaynakMetin)

    If Matches.Count = 0 Then
        MsgBox "'http://' veya 'https://' ile başlayan bir adres bulunamadı.", vbInformation
        Exit Sub
    End If

    ' Kaynak hücrenin bir alt satırından itibaren olası eski verileri temizle
    If hedefBaslangicHucre.Offset(1, 0).Row <= hedefBaslangicHucre.Worksheet.Rows.Count Then
        Dim sonDoluSatir As Long
        sonDoluSatir = hedefBaslangicHucre.Worksheet.Cells(Rows.Count, hedefBaslangicHucre.Column).End(xlUp).Row
        ' Temizlenecek alan, kaynak hücrenin bir altından başlar ve dolu olan son satıra kadar gider
        If sonDoluSatir >= hedefBaslangicHucre.Row + 1 Then
            hedefBaslangicHucre.Worksheet.Range(hedefBaslangicHucre.Offset(1, 0), hedefBaslangicHucre.Worksheet.Cells(sonDoluSatir, hedefBaslangicHucre.Column)).ClearContents
        End If
    End If

    satirOfseti = 1 ' Yazmaya kaynak hücrenin BİR ALT satırından başla

    ' Bulunan her eşleşmeyi (protokol başlangıcını) kullanarak URL'leri ayır ve yaz
    For i = 0 To Matches.Count - 1
        Dim currentMatchStart As Long
        currentMatchStart = Matches(i).FirstIndex + 1 ' Eşleşmenin başladığı pozisyon (1 tabanlı)
        
        Dim urlText As String
        If i < Matches.Count - 1 Then
            ' Bir sonraki eşleşme varsa, mevcut eşleşmeden bir sonrakine kadar olan kısmı al
            Dim nextMatchStart As Long
            nextMatchStart = Matches(i + 1).FirstIndex + 1
            urlText = Trim(Mid(kaynakMetin, currentMatchStart, nextMatchStart - currentMatchStart))
        Else
            ' Bu son eşleşme, metnin kalanını al
            urlText = Trim(Mid(kaynakMetin, currentMatchStart))
        End If
        
        If Len(urlText) > 0 Then
            hedefBaslangicHucre.Offset(satirOfseti, 0).Value = urlText
            satirOfseti = satirOfseti + 1
        End If
    Next i

    If satirOfseti = 1 Then ' Hiçbir URL yazılmadıysa (çok düşük bir ihtimal, Matches.Count > 0 ise)
        MsgBox "Adresler ayrıştırılamadı veya geçerli URL bulunamadı.", vbExclamation
    Else
        MsgBox (satirOfseti - 1) & " adet internet adresi başarıyla ayrıldı ve bir alt satırdan itibaren yazıldı.", vbInformation
    End If

End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,112
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Ofis 365 için alternatif çözüm...

C++: 
="Https"&METİNBÖL(A1;;"Https";1;1)
 
A

ADER_34

Katılım
2 Haziran 2015
Mesajlar
312
Excel Vers. ve Dili
2010
volki_112' Alıntı:
istediğiniz kod
Kod: 
Sub HttpAdresleriniBolVeAltSatiraYaz()

    Dim kaynakHucre As Range
    Dim hedefBaslangicHucre As Range
    Dim kaynakMetin As String
    Dim satirOfseti As Long
   
    Dim RegEx As Object
    Dim Matches As Object
    Dim Match As Object
    Dim i As Long

    ' Kullanıcıdan kaynak hücreyi seçmesini iste
    On Error Resume Next
    Set kaynakHucre = Application.InputBox("Lütfen 'Https' veya 'Http' ile başlayan adresleri içeren TEK BİR hücreyi seçin:", "Kaynak Hücre Seçimi", Type:=8)
    On Error GoTo 0

    If kaynakHucre Is Nothing Then
        MsgBox "Hücre seçilmedi, işlem iptal edildi.", vbInformation
        Exit Sub
    End If

    If kaynakHucre.Cells.CountLarge > 1 Then
        MsgBox "Lütfen sadece tek bir hücre seçin.", vbExclamation
        Exit Sub
    End If

    kaynakMetin = kaynakHucre.Value
    Set hedefBaslangicHucre = kaynakHucre ' Yazma işlemi bu hücreye göre ofsetlenecek

    ' Düzenli ifade (Regular Expression) nesnesini oluştur
    Set RegEx = CreateObject("VBScript.RegExp")
    With RegEx
        .Global = True      ' Metindeki tüm eşleşmeleri bul
        .IgnoreCase = True  ' Büyük/küçük harf duyarsız arama (http, Http, HTTP vb.)
        .Pattern = "https?://" ' "http://" veya "https://" ile başlayan kısımları bul
    End With

    Set Matches = RegEx.Execute(kaynakMetin)

    If Matches.Count = 0 Then
        MsgBox "'http://' veya 'https://' ile başlayan bir adres bulunamadı.", vbInformation
        Exit Sub
    End If

    ' Kaynak hücrenin bir alt satırından itibaren olası eski verileri temizle
    If hedefBaslangicHucre.Offset(1, 0).Row <= hedefBaslangicHucre.Worksheet.Rows.Count Then
        Dim sonDoluSatir As Long
        sonDoluSatir = hedefBaslangicHucre.Worksheet.Cells(Rows.Count, hedefBaslangicHucre.Column).End(xlUp).Row
        ' Temizlenecek alan, kaynak hücrenin bir altından başlar ve dolu olan son satıra kadar gider
        If sonDoluSatir >= hedefBaslangicHucre.Row + 1 Then
            hedefBaslangicHucre.Worksheet.Range(hedefBaslangicHucre.Offset(1, 0), hedefBaslangicHucre.Worksheet.Cells(sonDoluSatir, hedefBaslangicHucre.Column)).ClearContents
        End If
    End If

    satirOfseti = 1 ' Yazmaya kaynak hücrenin BİR ALT satırından başla

    ' Bulunan her eşleşmeyi (protokol başlangıcını) kullanarak URL'leri ayır ve yaz
    For i = 0 To Matches.Count - 1
        Dim currentMatchStart As Long
        currentMatchStart = Matches(i).FirstIndex + 1 ' Eşleşmenin başladığı pozisyon (1 tabanlı)
       
        Dim urlText As String
        If i < Matches.Count - 1 Then
            ' Bir sonraki eşleşme varsa, mevcut eşleşmeden bir sonrakine kadar olan kısmı al
            Dim nextMatchStart As Long
            nextMatchStart = Matches(i + 1).FirstIndex + 1
            urlText = Trim(Mid(kaynakMetin, currentMatchStart, nextMatchStart - currentMatchStart))
        Else
            ' Bu son eşleşme, metnin kalanını al
            urlText = Trim(Mid(kaynakMetin, currentMatchStart))
        End If
       
        If Len(urlText) > 0 Then
            hedefBaslangicHucre.Offset(satirOfseti, 0).Value = urlText
            satirOfseti = satirOfseti + 1
        End If
    Next i

    If satirOfseti = 1 Then ' Hiçbir URL yazılmadıysa (çok düşük bir ihtimal, Matches.Count > 0 ise)
        MsgBox "Adresler ayrıştırılamadı veya geçerli URL bulunamadı.", vbExclamation
    Else
        MsgBox (satirOfseti - 1) & " adet internet adresi başarıyla ayrıldı ve bir alt satırdan itibaren yazıldı.", vbInformation
    End If

End Sub
Genişletmek için tıkla ...
volki_112' Alıntı:
istediğiniz kod
Kod: 
Sub HttpAdresleriniBolVeAltSatiraYaz()

    Dim kaynakHucre As Range
    Dim hedefBaslangicHucre As Range
    Dim kaynakMetin As String
    Dim satirOfseti As Long
   
    Dim RegEx As Object
    Dim Matches As Object
    Dim Match As Object
    Dim i As Long

    ' Kullanıcıdan kaynak hücreyi seçmesini iste
    On Error Resume Next
    Set kaynakHucre = Application.InputBox("Lütfen 'Https' veya 'Http' ile başlayan adresleri içeren TEK BİR hücreyi seçin:", "Kaynak Hücre Seçimi", Type:=8)
    On Error GoTo 0

    If kaynakHucre Is Nothing Then
        MsgBox "Hücre seçilmedi, işlem iptal edildi.", vbInformation
        Exit Sub
    End If

    If kaynakHucre.Cells.CountLarge > 1 Then
        MsgBox "Lütfen sadece tek bir hücre seçin.", vbExclamation
        Exit Sub
    End If

    kaynakMetin = kaynakHucre.Value
    Set hedefBaslangicHucre = kaynakHucre ' Yazma işlemi bu hücreye göre ofsetlenecek

    ' Düzenli ifade (Regular Expression) nesnesini oluştur
    Set RegEx = CreateObject("VBScript.RegExp")
    With RegEx
        .Global = True      ' Metindeki tüm eşleşmeleri bul
        .IgnoreCase = True  ' Büyük/küçük harf duyarsız arama (http, Http, HTTP vb.)
        .Pattern = "https?://" ' "http://" veya "https://" ile başlayan kısımları bul
    End With

    Set Matches = RegEx.Execute(kaynakMetin)

    If Matches.Count = 0 Then
        MsgBox "'http://' veya 'https://' ile başlayan bir adres bulunamadı.", vbInformation
        Exit Sub
    End If

    ' Kaynak hücrenin bir alt satırından itibaren olası eski verileri temizle
    If hedefBaslangicHucre.Offset(1, 0).Row <= hedefBaslangicHucre.Worksheet.Rows.Count Then
        Dim sonDoluSatir As Long
        sonDoluSatir = hedefBaslangicHucre.Worksheet.Cells(Rows.Count, hedefBaslangicHucre.Column).End(xlUp).Row
        ' Temizlenecek alan, kaynak hücrenin bir altından başlar ve dolu olan son satıra kadar gider
        If sonDoluSatir >= hedefBaslangicHucre.Row + 1 Then
            hedefBaslangicHucre.Worksheet.Range(hedefBaslangicHucre.Offset(1, 0), hedefBaslangicHucre.Worksheet.Cells(sonDoluSatir, hedefBaslangicHucre.Column)).ClearContents
        End If
    End If

    satirOfseti = 1 ' Yazmaya kaynak hücrenin BİR ALT satırından başla

    ' Bulunan her eşleşmeyi (protokol başlangıcını) kullanarak URL'leri ayır ve yaz
    For i = 0 To Matches.Count - 1
        Dim currentMatchStart As Long
        currentMatchStart = Matches(i).FirstIndex + 1 ' Eşleşmenin başladığı pozisyon (1 tabanlı)
       
        Dim urlText As String
        If i < Matches.Count - 1 Then
            ' Bir sonraki eşleşme varsa, mevcut eşleşmeden bir sonrakine kadar olan kısmı al
            Dim nextMatchStart As Long
            nextMatchStart = Matches(i + 1).FirstIndex + 1
            urlText = Trim(Mid(kaynakMetin, currentMatchStart, nextMatchStart - currentMatchStart))
        Else
            ' Bu son eşleşme, metnin kalanını al
            urlText = Trim(Mid(kaynakMetin, currentMatchStart))
        End If
       
        If Len(urlText) > 0 Then
            hedefBaslangicHucre.Offset(satirOfseti, 0).Value = urlText
            satirOfseti = satirOfseti + 1
        End If
    Next i

    If satirOfseti = 1 Then ' Hiçbir URL yazılmadıysa (çok düşük bir ihtimal, Matches.Count > 0 ise)
        MsgBox "Adresler ayrıştırılamadı veya geçerli URL bulunamadı.", vbExclamation
    Else
        MsgBox (satirOfseti - 1) & " adet internet adresi başarıyla ayrıldı ve bir alt satırdan itibaren yazıldı.", vbInformation
    End If

End Sub
Genişletmek için tıkla ...
volki 12 sorunsuz çalışıyor çok teşekkür ederim,süper bir kod ayrıca hücreyi kendim belirlemem ayrıca güzel olmuş,elinize sağlık.iyi çalışmalar.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,112
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Split komutu ile verileri bölme işlemi daha pratik olabilir...

C++: 
Option Explicit

Sub Split_Text()
    Dim Selected_Rng As Range, Rng As Range
    Dim X As Long, My_Data As Variant, No As Long
    
    Set Selected_Rng = Selection
    
    For Each Rng In Selected_Rng
        My_Data = Split(Trim(Rng.Value), "Https", , vbTextCompare)
        ReDim My_List(1 To Rows.Count, 1 To 1)
        For X = LBound(My_Data) To UBound(My_Data)
            If Len(My_Data(X)) > 0 Then
                No = No + 1
                My_List(No, 1) = "Https" & My_Data(X)
            End If
        Next
        Rng.Offset(, 1).Resize(No, 1) = My_List
    Next
    
    MsgBox "Verileri ""HTTPS"" ifadesine göre bölme işlemi tamamlanmıştır."
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst