• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

yan yana satırları alt alta yazmak.

W

webuyeislemleri

Katılım
29 Mayıs 2008
Mesajlar
81
Excel Vers. ve Dili
2007
Ürün Depo1 Depo2
Elma 10 5
Armut 0 200

Farklı sayfada sokmak istediğim düzen ;
Elma Depo1 10
Elma Depo2 5
Armut Depo2 200


yardımlarınızı bekliyorum.
 

Ekli dosyalar

. . .

Kod: 
Sub KOD()
Application.ScreenUpdating = False

Dim S1 As Worksheet
Dim S2 As Worksheet
Set S1 = Sheets("SAYFA1")
Set S2 = Sheets("SAYFA2")

S2.Range("a1:c65536").ClearContents
s1son = S1.[a65536].End(3).Row
s2son = 1
sütun = S1.[IV1].End(1).Column


For i = 2 To s1son
For a = 2 To sütun

If S1.Cells(i, "a") <> "" Then

S2.Cells(s2son, "a") = S1.Cells(i, "a")
S2.Cells(s2son, "b") = S1.Cells(1, a)

If S1.Cells(i, a) <> 0 Then
S2.Cells(s2son, "c") = S1.Cells(i, a)

s2son = s2son + 1

Else: End If
Else: End If

Next a
Next i

Set S1 = Nothing
Set S2 = Nothing
i = Empty
a = Empty
s1son = Empty
s2son = Empty
sütun = Empty

Application.ScreenUpdating = True
MsgBox " B İ T T İ "
End Sub

. . .
 
Arkadaşlar Merhaba,

Bu konu ile ilgili benimde bir ihtiyacım doğru yalnız var olan makro benim işimi görmüyor belki bir kaç dokunuş ile benim aşağıda vereceğim örnek gibi bir çalışma konusunda yardımcı ola bilirsiniz diye düşünüyorum.


Sayfa1 de var olan ürünleri sayfa2 deki hale getirmek istiyorum konunun özü bu

Detayı ise:

Bu liste de sabit tutacağımız tek yer '' ürün kodu '' alanı sabit tutarak diğer alanları buna göre alt alta getirmek istiyorum.

Ekstre olarak eğersay ile her alanın saydırdım bunuda makroya bağlaya bilirsek süper olur.

Önemli Not:

Sıfır (0) ile başlayan numaralar olunca sıfır kaybolmaması gerekli bu detay önemli şimdiden teşekkürler..


http://s5.dosya.tc/server/esdpm4/yan_yana_satirlari_alt_alta_yazmak.xlsx.html
 
Aşağıdaki kod istediğiniz gibi aktarır.
Kod: 
Sub Makro1()
kere = Sheets("Sayfa1").Range("A65536").End(3).Row
Sheets("Sayfa1").Range("B2:AZ2").Copy
say = 1
For i = 1 To kere - 1

Sheets("Sayfa2").Range("B" & say + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Sheets("Sayfa2").Range("A" & say + 1 & ":A" & say + 51).Value = Sheets("Sayfa1").Range("A" & i + 1)
say = say + 51
Next

Sheets("Sayfa1").Range("B1:AZ1").Copy
For i = 1 To kere - 1
say = 1
say = Sheets("Sayfa2").Range("C65536").End(3).Row
Sheets("Sayfa2").Range("C" & say + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
say = say + 51
Next
son = Sheets("Sayfa2").Range("A65536").End(3).Row
Sheets("Sayfa2").Range("D2:F" & son).FormulaR1C1 = "=COUNTIF(C[-3],C[-3])"

End Sub
 
Ali Hocam,

Ellerine sağlık gene tam istediğim gibi olmuş.

Teşekkürler
 
Ali Hocam Merhaba,

ilk başta gözüme çarpmayan bir durumu fark ettim makroda şöyle bir döngü var veri alanında olan tek ürünü formül çalıştıktan sonra 3 tane eklemiş müsaitseniz makroyu kontrol edermisiniz.

Örnek olarak veri '' W01 M58 0031 '' baz ala bilirsiniz sayfa1 de bir tek kalem iken makro çalıştıktan sonra sayfa2 ye 3 ayrı ürün kod kısmına yazmış yardımlarınızı bekliyorum.
 
Merhaba Arkadaşlar,

Konu ile ilgili yardımlarınızı bekliyorum..
 
Merhaba,
Tüm satırı seçim Ctr+C yapın sonra kopyalayacağınız hücreye gelip mouse ile sağ tıklayıp özel yapıştır dan işlemi tersine çeviri işaretleyip tamamı tıklayın.
 
Merhaba,

Öneriniz için teşekkür ederim.

Fakat bu işlem yapmak istediğim işlemde işimi görmüyor örnek verdiğim excel gibi olmalı bir çok listem var bunları ancak bu şekilde çöze bilirim.

bu konuda yardımcı ola bilecek arkadaşlardan yardım bekliyorum.
 
yasin85' Alıntı:
Merhaba,

Öneriniz için teşekkür ederim.

Fakat bu işlem yapmak istediğim işlemde işimi görmüyor örnek verdiğim excel gibi olmalı bir çok listem var bunları ancak bu şekilde çöze bilirim.

bu konuda yardımcı ola bilecek arkadaşlardan yardım bekliyorum.
Genişletmek için tıkla ...

Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Sub aktar59()
Dim sh As Worksheet, i As Long, myarr(), liste(), baslik As String
Dim sonsat As Long, n As Long, z As Object, j As Integer, deg As String
Sheets("Sayfa2").Select
Range("A2:C" & Rows.Count).ClearContents
Set sh = Sheets("Sayfa1")
sonsat = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
liste = sh.Range("A2:AZ" & sonsat).Value
sonsat = sonsat * 52
ReDim myarr(1 To 3, 1 To sonsat * 52)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    deg = liste(i, 1)
    For j = 2 To 52
        deg = deg & liste(i, j) & sh.Cells(1, j).Value
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = liste(i, 1)
            myarr(2, n) = liste(i, j)
            myarr(3, n) = sh.Cells(1, j)
        End If
    Next j
    deg = ""
Next i
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ReDim Preserve myarr(1 To 3, 1 To z.Count)
Set z = Nothing: Erase liste()
Range("A2").Resize(n, 3) = Application.Transpose(myarr)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub
 

Ekli dosyalar

Evren Hocam,

Testlerimi yaptım bir sorunla karşılaşmadım istediğim gibi veriler doğru geliyor.
Allah razı olsun süper olmuş çok teşekkür ederim. :)
 
yasin85' Alıntı:
Evren Hocam,

Testlerimi yaptım bir sorunla karşılaşmadım istediğim gibi veriler doğru geliyor.
Allah razı olsun süper olmuş çok teşekkür ederim. :)
Genişletmek için tıkla ...

Rica ederim.
İyi çalışmalar.:cool:
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst