Transpose yaparken değeri aynı atasın

[search77]

Merhaba Arkadaşlar,

Ekli excelimde transpose yapan macro vardır, fakat işlemi yaparken sheet1 deki değerleri Sheet2 ye transpose yaparken aynı şekilde almasını istiyorum, sayılar 16 karakter ve üstü olduğunda hepsini numbera çeviriyor ve sonlarını 0 yapıyor,

Macro içeriğinde nereyi değiştirmeliyim, acil yardım lütfen.

Saygılarımla.

 

[Muhammet Okumuş]

Hücre biçimini metin olarak ayarlayın.

 

[alicimri]

Kırmızı ile hedef olarak belirtilen yeri kendinize uyarlayın.

[COLOR="Red"]hedef[/COLOR].PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=True

 

[YUSUF44]

Koddaki .Value kısımlarını silerseniz verileri aynen aktarır.

 

[Muhammet Okumuş]

Koddaki .Value yazılan yerleri siliniz.

 

[Muhammet Okumuş]

Yusuf Bey'in cevabını sonradan gördüm.

 

[Ömer]

Merhaba,

Fazladan bir döngüden kurtarmak için alternatif olsun.

Sub Transpoze()

    Dim S1 As Worksheet, son As Long, i As Long, sut As Integer
    
    Set S1 = Sheets("Sheet1")
    
    Application.ScreenUpdating = False
    Sheets("Transpose Yap").Select
    Range("A:B").ClearContents
    
    son = 1
    For i = 1 To S1.Cells(Rows.Count, "A").End(xlUp).Row
        sut = S1.Cells(i, Columns.Count).End(xlToLeft).Column
        S1.Cells(i, "B").Resize(1, sut).Copy
        Cells(son, "A") = S1.Cells(i, "A")
        Cells(son, "B").PasteSpecial Paste:=xlPasteValues, _
            Operation:=xlNone, Transpose:=True
        son = Cells(Rows.Count, "B").End(xlUp).Row + 1
    Next i
    
    Range("A1").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
        
End Sub

.

 

[search77]

Arkadaşlar süper süper süpersiniz, tam istediğim gibi olmuş

Herkesin bilgisine emeğine sağlık, iyiki varsınız.

Saygı ve sevgilerimle