• DİKKAT

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

Yan yana olan verileri yazdırma

K

KARTAL133

Katılım
12 Şubat 2009
Mesajlar
185
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba Arkadaşlar

Makro olarak yan yana olan verileri alt alta nasıl yazırdıra bilirim.
Örnek dosya ektedir.
Yardımlarını rica ederim.
 

Ekli dosyalar

Merhaba.

-- Belgenize yeni adlı bir sayfa ekleyin,
-- örnek belgenizdeki gibi alt tarafta yer alan "olması gereken tablo"
gibi gereksiz veri varsa o satırları silin,
-- aşağıdaki kod'u çalıştırın.
.
Kod: 
[FONT="Arial Narrow"][B]Sub ALTALTA()[/B]
Set s1 = Sheets("Sheet1"): Set y = Sheets("yeni")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
s1.Activate: y.Cells.ClearContents
s1.Columns("E:F").Insert Shift:=xlToRight
For sat = 2 To s1.[A65536].End(3).Row
    For grup = 1 To 4
ysat = y.[A65536].End(3).Row + 1
s1.Range(s1.Cells(sat, ((grup - 1) * 6) + 1), s1.Cells(sat, ((grup - 1) * 6) + 6)).Copy _
y.Cells(ysat, 1)
    Next
Next
y.Columns.AutoFit
s1.Columns("E:F").Delete Shift:=xlToLeft: s1.Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı..", vbInformation, "..:: O.BARAN ::.."
[B]End Sub[/B][/FONT]
 
istediğim gibi olmuş
Yardımlarınız için çok teşekkürler
 
az önce birsey denedim yapılan 3 acıklama lı bir çalışma 4 5 veya 6 olursa nasıl bir yol izlemem gerekiyor ?
 
Tekrar merhaba.

Cevaplarımın altındaki İMZA bölümünde yer alan açıklamayı tekrarlamak ve biraz açmak durumundayım.
Sorularınızı, gerçek belgenizle aynı yapıda örnek belge üzerinden sorunuz.
(sayfa/satır/sütun/veri başlangıç satırı/metin-sayı-tarih vs hücre biçimleri gibi)

Örnek belgeler bu şekilde hazırlanırsa, ben veya başka bir üye sorularınızı cevapsız bırakmayacaktır.
.
 
fat

Çalışmayı bir az değiştirdim
ne kadarını olur bilemedim
Kullancağım işlem aylık 1000 yakın fat. giriş yapıyorum sisteme aktara bilmem için ekteki çalışmayı tamam lazım önceki çalışmayı sisteme attım eksikler olduğundan dolayı olmadı. ekteki formatta hazırlamam gerekti.
yardımlarınız için teşekkürler
 

Ekli dosyalar

Merhaba.

Bu istediğiniz biraz daha farklı.
Ben şöyle düşündüm E sütununa kadarki kısım 4 sütun diğerleri ise 6'şar sütunluk gruplar halinde.
Kod, E:F'ye iki boş sütun ilave edip hepsini 6'şarlı hale getiriyor (bu koddaki grup sayısı oluyor),
işlemleri tamamlayıp bu sütunları siliyor.

Son örnek belgeniz için kod aşağıdaki şekilde düzenlenebilir.
Veri kaynağı Sheet1, veri yazılacak sayfa adı yeni.
.
Kod: 
[FONT="Arial Narrow"][B]Sub ALTALTA2()[/B]
Set s1 = Sheets("Sheet1"): Set y = Sheets("yeni")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
s1.Activate: y.[A:A].ClearContents
s1.Columns("E:F").Insert Shift:=xlToRight
For sat = 2 To s1.[A65536].End(3).Row
    For grup = 1 To 8
ysat = y.[A65536].End(3).Row + 1
    bir = s1.Cells(sat, ((grup - 1) * 6) + 1).Value
    iki = s1.Cells(sat, ((grup - 1) * 6) + 2).Value
    üç = s1.Cells(sat, ((grup - 1) * 6) + 3).Value
    dört = s1.Cells(sat, ((grup - 1) * 6) + 4).Value
    metin = bir & ":" & iki & ":" & üç & ":" & dört
If grup = 1 Then GoTo 10
    beş = s1.Cells(sat, ((grup - 1) * 6) + 5).Value
    altı = s1.Cells(sat, ((grup - 1) * 6) + 6).Value
    metin = metin & ":" & beş & ":" & altı
10: y.Cells(ysat, 1) = metin
metin = ""
    Next
Next
y.Columns.AutoFit
s1.Columns("E:F").Delete Shift:=xlToLeft: s1.Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı..", vbInformation, "..:: O.BARAN ::.."
[B]End Sub[/B][/FONT]
 
Merhaba,
Bende yazmıştım. Alternatif olsun.

Kod: 
Option Explicit
Sub Listele()
Dim a(), b(), deg, Veri_say As Long
Dim i As Long, y As Long, x As Long, Say As Long
Sheets("yeni").Select
a = Range("A2:AT" & Cells(Rows.Count, 1).End(3).Row)
Veri_say = Application.CountA(a)
ReDim b(1 To Veri_say, 1 To 1)

    For i = 1 To UBound(a)
        Say = Say + 1
        For y = 2 To 4
            deg = deg & " : " & a(i, y)
            b(Say, 1) = a(i, 1) & deg
        Next y
        deg = ""
        For y = 5 To UBound(a, 2) Step 6
            For x = 1 To 5
                deg = deg & " : " & a(i, y + x)
                b(Say + 1, 1) = a(i, y) & deg
            Next x
            deg = ""
            Say = Say + 1
        Next y
    Next i
Sheets("sayfa1").Range("A2:A" & Rows.Count).ClearContents
Sheets("sayfa1").[A2].Resize(Veri_say) = b
Sheets("sayfa1").Select
MsgBox "İşlem Tamam.", vbInformation
End Sub
 

Ekli dosyalar

Merhaba Arkadaşlar

Yardımlarınız için çok teşekkürler
 
kod

İyi aksamlar Arkadaşlar

Bendeki kodlama Değişiyor hep rahatsız ettiğim için özür dilerim.
Önceki kodlamanın aynısı ben uğrastım ama yapamadım ektelin göre yapa bilmenizi mümkün mü. ayrıca txt olarak kayıt etmesini istiyorum.

sizleri uğrastırdığım için kusura bakmayın
 

Ekli dosyalar

Tekrar merhaba.

Aşağıdaki kod'u dener misiniz?
Kod bilgileri Aktarma sayfasına, aralara : ekleyerek aktarır ve Aktarma sayfasını, belgenin bulunduğu klasöre TXT formatında kaydeder.
.
Dikkat: İşlem yapılacak belgedeki formüllerin hata vermediğinden ve döngüsel başvuru içermediğinden emin olunuz.
.
Kod: 
[FONT="Arial Narrow"][B]Sub KARTAL133_BRN()[/B]
Set f = Sheets("Fat"): Set a = Sheets("Aktarma")
a.[A:A].ClearContents
For sat = 2 To f.[A65536].End(3).Row
    For sol = 1 To 33
        brn = brn & ":" & f.Cells(sat, sol).Value
    Next
    a.Cells(a.[A65536].End(3).Row + 1, 1) = Mid(brn, 2, Len(brn) - 1)
    brn = ""
    For grup = 1 To 8
        For gr = 1 To 17
            grp = grp & ":" & f.Cells(sat, sol + ((grup - 1) * 17) + gr - 1).Value
        Next
            a.Cells(a.[A65536].End(3).Row + 1, 1) = Mid(grp, 2, Len(grp) - 1)
            grp = ""
    Next
Next
a.SaveAs Filename:=ThisWorkbook.Path & "\" & "Aktarma.txt", FileFormat:=xlTextPrinter
MsgBox "Aktarma sayfası, bu belgenin bulunduğu klasöre TXT formatında kaydedildi.", _
        vbInformation, "..:: O.BARAN ::.."
[B]End Sub[/B][/FONT]
 
Aktarma

Ömer bey

Yardımlarınız için çok teşekkürler
Bir sorun var sanırım Yan yana 8 kadar gidiyor sorun yok
ama tutar olmadığı zaman 2 veya 3 kesip bir alta yazması gerliyor ancak 8 kadar gelip bos satırlar (:::::::::: ) olarak çıkartıp diğerine devam ediyor örken txt ektedir. umarım anlata bildim.
 

Ekli dosyalar

Merhaba.

İlk grup 33 sütun (ben bunu sol olarak adlandırdım), sonrakiler (grup olarak adlandırdım) ise 17'şer sütun (ben gr olarak adlandırdım) idi.
Ben tüm sütunlara elle veriler girerek deneme yaptığımda sorun göremiyorum.
Mevcut örnek belgenizde formüller vardı (üstelik döngüsel başvuru hatası içeren de var).

Gerçek belgenizin gerçek birkaç satırlık verisi olsaydı ve bu satırlar için olması gereken halini elle yazarak hazırlasaydınız, deneme yapmak daha kolay olurdu.
17 sütunluk gruplar için belli net bir kural varsa (örneğin grubun ilk hücresi boş ise o grup için satır açılmayacak gibi) bunu açık şekilde ifade etmelisiniz.
.
 
Yanlışlıkla mükerrer gönderilen cevap silindi..
 
Evet Hocam Biliyorum
çok güzel bir çalışma yapmışsınız
bende çok uğraştım yapamadım :(
makrodan fazla anlamıyorum.
 
AH2 hücresindeki (aynı formül benzer sütun ve satırlarda var) formülünüzde sorun var, sanırım doğrusu =EĞER((SOLDAN(AI2;1))="6";"IND";"ınf") şeklinde olacak.
Ayrıca; P, Q ve S gibi bazı sütunlarda da HATA sonucunu veren formülleriniz var.

Bunları kontrol ederek deneyin. (Kontrolü, gerçek belgenizi kapatıp, yüklediğiniz örnek belgeyi forumdan indrerek onun üzerinden yapın.
Ayrıca satır açmama kuralı konusunu net ifade etmiyorsunuz, ben örnek vermiştim.
Bu kuralı siz söyleyeceksiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst