belli satır aralığındaki boşluklu veri

[farisakboga]

ekteki dosyada manuel olarak islem sayfasında yaptığım işlemi yani sablon sayfasında d1 ile r1 arasındaki hücreleri belittiğim kutucuklara aralarında boşluk olmaksızın nasıl alabilirim?
tümü için uygulayabileceğim formül nedir?

 

[askm]

Aşağıdaki kodları kullanabilirsiniz.

Sub askm()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("sablon")
Set s2 = Sheets("islem")
a = 1
Application.ScreenUpdating = False
For i = 1 To s1.Range("A" & Rows.Count).End(3).Row
    s = 3
    For x = 3 To 18
        If s1.Cells(i, x) <> Empty Then
            s2.Cells(a, s) = s1.Cells(i, x)
            s = s + 1
        End If
    Next x
    a = a + 2
Next i
s2.Columns("C:L").EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[farisakboga]

Aşağıdaki kodları kullanabilirsiniz.

Sub askm()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("sablon")
Set s2 = Sheets("islem")
a = 1
Application.ScreenUpdating = False
For i = 1 To s1.Range("A" & Rows.Count).End(3).Row
    s = 3
    For x = 3 To 18
        If s1.Cells(i, x) <> Empty Then
            s2.Cells(a, s) = s1.Cells(i, x)
            s = s + 1
        End If
    Next x
    a = a + 2
Next i
s2.Columns("C:L").EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

çok teşekkür ederim.
sablon sayfasındaki hücrelerin bazılarında 2 basamaklı sayılar var. onları da islem sayfasında ayırıp tek tek hücrelere yazdırabilir miyiz?
örneğin bir hücredeki 14 sayısı islem sayfasında 1 ve 4 olarak 2 ayrı hücrede görünsün.

 

[askm]

Aşağıdaki şekilde deneyin.

Sub askm()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("sablon")
Set s2 = Sheets("islem")
a = 1
Application.ScreenUpdating = False
For i = 1 To s1.Range("A" & Rows.Count).End(3).Row
    s = 3
    For x = 3 To 18
        If s1.Cells(i, x) <> Empty Then
            If Len(Trim(s1.Cells(i, x))) > 1 Then
                s2.Cells(a, s) = Left(s1.Cells(i, x), 1)
                s = s + 1
                s2.Cells(a, s) = Right(s1.Cells(i, x), 1)
            Else
                s2.Cells(a, s) = s1.Cells(i, x)
            End If
            s = s + 1
        End If
    Next x
    a = a + 2
Next i
s2.Columns("C:L").EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[farisakboga]

Aşağıdaki şekilde deneyin.

Sub askm()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("sablon")
Set s2 = Sheets("islem")
a = 1
Application.ScreenUpdating = False
For i = 1 To s1.Range("A" & Rows.Count).End(3).Row
    s = 3
    For x = 3 To 18
        If s1.Cells(i, x) <> Empty Then
            If Len(Trim(s1.Cells(i, x))) > 1 Then
                s2.Cells(a, s) = Left(s1.Cells(i, x), 1)
                s = s + 1
                s2.Cells(a, s) = Right(s1.Cells(i, x), 1)
            Else
                s2.Cells(a, s) = s1.Cells(i, x)
            End If
            s = s + 1
        End If
    Next x
    a = a + 2
Next i
s2.Columns("C:L").EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

emekleriniz için çok teşekkürler.
ancak denediğimde sonuçlar uyumlu olmuyor.
herhalde ben beceremedim.
kodu örnek dosyaya ekleyerek paylaşabilir misiniz?