Soru HÜCRE İÇİNDEKİ BİLGİLERİ SATIRA AYIRMA

[ozanyakar]

Merhaba,
Ekli dosya 3 sütundan oluşmakta

B Sütununda hücrelerin içinde birden fazla alt alta ya da yan yana bu şekilde veriler var

Örneğin bir hücrede :

##1 GB DDR2 800 MHZ KINGSTON, 5, ADET, 2.6.2022 21:00:00 +00:00, deneme#160 GB SATA-2 7200 RPM 8 MB SAMSUNG, 10, ADET, 27.4.2021 21:00:00 +00:00, TEST#
1 GB DDR2 800 MHZ KINGSTON, 1, ADET, 11.4.2021 21:00:00 +00:00, REST#

şeklinde yer alan veriyi, hemen yandaki SONUÇ isimli sayfaya #veri# (iki işaret arasındaki değerler) alıp alt alta nasıl yazdırabiliriz ?

Alt alta yazdırdığımızda satırın sağında c sütununda yer alan değerde her bir satır için hemen c sütununda olmalı.

Kıymetli yardımlarınızı rica ederim üstatlar. Saygılar sunarım.

 

[ÖmerFaruk]

Dosyanızdaki 7.satırda (Ref sütununda 232 olan) bulunan metinden alınacak veri sadece
2 GB DDR2 800 MHZ KINGSTON, 10, ADET, 8.6.2022 21:00:00 +00:00, seker
bu mudur?
Zira # işareti sadece bu metinin başında ve sonunda var.

 

[ozanyakar]

Sayın
ÖmerFaruk doğru # # işaret arasındaki verileri , yan sayfaya alt alta yazdırmak istiyoruz. Hem sağında c hücresindeki değeri de c hücresine alt alta yazmalıyız. Yardımlarınızı rica ederim.

 

[ozanyakar]

Sayın
ÖmerFaruk doğru # # işaret arasındaki verileri , yan sayfaya alt alta yazdırmak istiyoruz. Hem sağında c hücresindeki değeri de c hücresine alt alta yazmalıyız. Yardımlarınızı rica ederim.

Üstat, hücrede alt alta ve yan yana veri varsa

# 1 # # 2 # # 3 #
#4 #

4 satır veri yazmalıyız.

 

[ÖmerFaruk]

Aşağıdaki kodu boş bir modül içine ekleyip çalıştırabilirsiniz.

Sub MetinDuzenle()
   Dim Sh1 As Worksheet, Sh2 As Worksheet, Son As Long, i As Long, Say As Long, k As Integer
   Dim Arr1 As Variant, Arr2 As Variant, Liste, Bak As String
   Set Sh1 = Worksheets("VERİ")
   Set Sh2 = Worksheets("SONUÇ")
   Son = Sh1.Range("A" & Rows.Count).End(3).Row
   If Son < 2 Then Exit Sub
   Arr1 = Sh1.Range("A2:C" & Son).Value
   ReDim Liste(1 To Rows.Count, 1 To 3)
   For i = 1 To UBound(Arr1)
      Bak = Arr1(i, 2)
      Bak = Mid(Bak, InStr(1, Bak, "#") + 1, Len(Bak) - InStr(1, Bak, "#"))
      Bak = Left(Bak, InStrRev(Bak, "#") - 1)
      Bak = Trim(Replace(Bak, "##", ""))
      Bak = Trim(Replace(Bak, "#", ","))
      Bak = Trim(Replace(Bak, Chr(10), ""))
      If Left(Bak, 1) = "," Then Bak = Trim(Mid(Bak, 2, Len(Bak) - 1))
      If Right(Bak, 1) = "," Then Bak = Trim(Mid(Bak, 1, Len(Bak) - 1))
      Arr2 = Split(Bak, ",")
      If UBound(Arr2) >= 4 Then
         For k = 0 To UBound(Arr2) Step 5
            Say = Say + 1
            Liste(Say, 1) = Arr1(i, 1)
            Liste(Say, 2) = Arr2(k) & "," & Arr2(k + 1) & "," & Arr2(k + 2) & "," & Arr2(k + 3) & "," & Arr2(k + 4)
            Liste(Say, 3) = Arr1(i, 3)
         Next k
      End If
   Next i
   Sh2.Cells.Clear
   Sh2.Range("A1:C1") = Sh1.Range("A1:C1")
   Sh2.Range("A2").Resize(Say, 3) = Liste
   Set Sh1 = Nothing: Set Sh2 = Nothing: Erase Arr1: Erase Arr2: Erase Liste: Bak = vbNullString
End Sub

 

[ozanyakar]

Sayın
ÖmerFaruk
Bir yerde hata yaptım sanırım, kodu çalıştıramadım, görseldeki hatayı alıyorum. Rica ediyorum, tekrar yardımcı olabilir misiniz ?

 

[ozanyakar]

Sayın @ÖmerFaruk
Problemi şimdi hallettim, çok teşekkür ederim ilginize. Saygılar sunarım.

 

[ÖmerFaruk]

Hata nerdeymiş?

 

[ozanyakar]

Üstat, ben kodu çalıştıramayınca başka bir hocamdan yardım istedim. Hata var mı bulamadım inanın, muhtemelen ben yanlış bir şey yaptım.
Dosyayı yüklüyorum ama başka bir şekilde kod yazdı. Nasıl yaptı hiç bilgim yok.
Desteğiniz için size de çok teşekkür ederim.