Satır aralığı sütun aralığa makro ile yazdırabilir miyiz?

[HiujiN]

AO5:BM5 aralığındaki değerler X9:X33 aralığına makro ile yazdırmak istiyorum. yani tek bir satırdaki yanyana değerler tek bir sütuna alt alta yazılabilir mi?

 

[askm]

Aşağıdaki kodu deneyin.

Sub ASKM()
    Application.ScreenUpdating = False
    Range("X9:X65000").ClearContents
    Range("AO5:BM5").Select
    Selection.Copy
    Range("X9").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("X9").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamlandı", vbInformation, "askm"
End Sub

 

[ugkabjk]

selamlar,

otomotiv sektöründeyim. üstünde çalıştığım bir excel dosyası var, bazı makroları okuyarak, deneyerek hallettim ama birinde kilitlendim ve çözemiyorum. bu çalışma kitabı ortak klasörde duruyor, diğer danışmanlarla aynı anda çalışıp kayıt alabiliyoruz.

Excel 2013 kullanıyoruz.
OtoEKSPER isimli çalışma sayfamda farklı sütunlara girdiğim takas araç ve müşteri bilgilerini TAKAS isimli çalışma sayfamda A ve Q sütunlarıyla sınırlı alana tek bir satırda kaydetmek, yani bir veritabanı oluşturmak istiyorum. OtoEKSPER' de kaydet düğmesine bastığımda girilmiş olan verileri TAKAS sayfasının boş olan satırına yapıştırıp kaydedecek ve her defasında boş olan alt satırdan devam edecek.

Kopyalanacak aralık ----> kaydetme konumu:

OtoEKSPER' deki ----> TAKAS'ta
F4:F9 ----> C:H sütunlarına
I4:I9 ----> I:N sütunlarına
J1 hücresi ----> A sütununa
G10 hücresi ----> B Sütununa
G11:G12 ----> sırasıyla O ve P sütunlarına gelecek

ve TAKAS çalışma sayfasının hücre biçimlendirme seçenekleri bozulmayacak. kenarlık şekli, yazı tipi aynen kalacak.

Bu konuda yardımcı olabilirseniz işime gücüme bakabileceğim, çok zaman kaybettim araştırma sürecinde.

teşekkürler.

 

[askm]

Aşağıdaki kodları deneyin.

Sub askm()
Dim s1, s2 As Worksheet
Set s1 = Worksheets("OtoEKSPER")
Set s2 = Worksheets("TAKAS")
Dim sonsatir As Long
Application.ScreenUpdating = False
sonsatir = s2.Cells(65536, 1).End(xlUp).Row + 1
s2.Cells(sonsatir, 1) = s1.Cells(1, 10) 'j1
s2.Cells(sonsatir, 2) = s1.Cells(10, 7) 'g10
s2.Cells(sonsatir, 3) = s1.Cells(4, 6) 'f4
s2.Cells(sonsatir, 4) = s1.Cells(5, 6) 'f5
s2.Cells(sonsatir, 5) = s1.Cells(6, 6) 'f6
s2.Cells(sonsatir, 6) = s1.Cells(7, 6) 'f7
s2.Cells(sonsatir, 7) = s1.Cells(8, 6) 'f8
s2.Cells(sonsatir, 8) = s1.Cells(9, 6) 'f9
s2.Cells(sonsatir, 9) = s1.Cells(4, 9) 'ı4
s2.Cells(sonsatir, 10) = s1.Cells(5, 9) 'ı5
s2.Cells(sonsatir, 11) = s1.Cells(6, 9) 'ı6
s2.Cells(sonsatir, 12) = s1.Cells(7, 9) 'ı7
s2.Cells(sonsatir, 13) = s1.Cells(8, 9) 'ı8
s2.Cells(sonsatir, 14) = s1.Cells(9, 9) 'ı9
s2.Cells(sonsatir, 15) = s1.Cells(11, 7) 'g11
s2.Cells(sonsatir, 16) = s1.Cells(12, 7) 'g12
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "askm"
End Sub

 

[ugkabjk]

arkadaşlarım da ben de çok teşekkür ediyoruz.

sorunsuz çalıştı.

sevgiler

 

[HiujiN]

Teşekkür ederim transpose kodu büyük ilham oldu. Sayende öğrendiğim formülü araştırınca;

Application.Transpose işimi gördü.