• DİKKAT

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

Etiket düzenleme sistemi yardım....

W

woodteacher

Katılım
19 Aralık 2011
Mesajlar
101
Excel Vers. ve Dili
2003
tr
E1 den E10 ve L1 den L10 a kadar olan etiket düzeninde
( E ve L. de sadece örnek olsun diye 1 yapraklık etiket örneği koydum,bu aşağı kadar devam ediyor düşünelim )

E ve L.deki etiketteki gruplarda
PARÇA ADI olan yerin karşısında metin vb.değer varsa o grubu ( EG ) deki ilk ayrılan boşluğa yerleştirsin.E1 de PARÇA ADI olan kısmı dolu olanları atadıktan sonra E2 ve .......L1 ve ..... hepsini tarasın sayfa sonuna kadar...
20 ayrı listedeki dolu olanları ( EG ) de sıralasın.....
Örnek çalışmada gösterdiğim PARÇA ADI olan kısımda ( - ) olanları atlasın görmesin.yok saysın..
Doldurmada sırasıyla soldan sağa sonrada aşağı tekrar sağa doğru olsun
 

Ekli dosyalar

Merhaba,

Ben sonuç olarak Tüm sayfalardaki bilgileri "EG" sayfasında birleştirmek istiyorsunuz. Bunu yaparkende "Parça Adı" dolu olan etiketler dikkate alınmasını istiyorsunuz, doğru anladım mı?
 
Aynen Necdet bey istediğim şey bu...
Orjinal dosyamda E1 den E10 ve L1 den L10 a kadar toplam 20 sayfa var....
örnek çalışmada herbirinde 1 sayfa örnek koydum normalde her birinde 5 sayafalık etiket tablosu var.toplam 20 x 5 den 100 sayfaya sığacak etiket.var....
Bunların içinde PARÇA ADI dolu olanların aynı diziliş mantığında (EG) de sıralanmasını isityorum..
önce E1...sırasıyla E10 kadar Sonra L1 ve L10 a kadar süzüp dolu olanları EG ye atmak....
 
Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Kod: 
Sub EG_Sayfasinda_Birlestir()
 
    On Error Resume Next
    
    Dim Sayfa   As Worksheet, _
        EG      As Worksheet, _
        i       As Long, _
        j       As Integer, _
        Kol     As Integer, _
        SonSat  As Long, _
        Sat     As Long
    
    Set EG = Sheets("EG")
    
    EG.Select
    
    Sat = 1
    Kol = -5
    
    Range("A:Q").ClearContents
    
    For Each Sayfa In Worksheets
    
        If Sayfa.Name Like "E-*" Or Sayfa.Name [B][COLOR=red]Like[/COLOR][/B] "L-*" Then
            SonSat = 0
            
            SonSat = Sayfa.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If SonSat > 0 Then
                For i = 1 To SonSat Step 10
                    For j = 1 To 13 Step 6
                        If Not Sayfa.Cells(i, j).Offset(4, 1) = "" And Not Sayfa.Cells(i, j).Offset(4, 1) = " - " Then
                            Kol = Kol + 6
                            If Kol > 13 Then
                                Kol = 1
                                Sat = Sat + 10
                            End If
                            Sayfa.Cells(i, j).CurrentRegion.Copy EG.Cells(Sat, Kol)
                        End If
                    Next j
                Next i
            End If
        End If
        
    Next Sayfa
    
End Sub
 

Ekli dosyalar

Son düzenleme:
Merhaba,

Ben sorunuzu biraz daha farklı algıladım. Alternatif olarak aşağıdaki kodu denermisiniz.

Kod: 
Sub ETİKETLERİ_AKTAR()
    Dim S1 As Worksheet
    Dim Sayfa As Worksheet
    Dim Satır As Integer, Sütun As Byte
    
    On Error GoTo Son
    Application.CalculateFull
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set S1 = Sheets("EG")
    Satır = 1
    Sütun = 1
    
    S1.Range("A:Q").ClearContents
    
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> "EG" And (Left(Sayfa.Name, 2) = "E-" Or Left(Sayfa.Name, 2) = "L-") Then
            For X = 1 To Sayfa.Cells(Rows.Count, 1).End(3).Row Step 10
                For Y = 2 To 14 Step 6
                    If Sayfa.Cells(X + 4, Y) <> "" And Sayfa.Cells(X + 4, Y) <> " - " Then
                        Sayfa.Range(Sayfa.Cells(X, Y - 1), Sayfa.Cells(X + 8, Y + 3)).Copy S1.Cells(Satır, Sütun)
                        S1.Range(S1.Cells(Satır, Sütun), S1.Cells(Satır + 8, Sütun + 4)).Copy
                        S1.Range(S1.Cells(Satır, Sütun), S1.Cells(Satır + 8, Sütun + 4)).PasteSpecial xlValues
                        Application.CutCopyMode = False
                        Sütun = Sütun + 6
                        If Sütun > 13 Then
                            Satır = Satır + 10
                            Sütun = 1
                        End If
                    End If
                Next
                If S1.Cells(Satır + 4, IIf(Sütun > 13, 13, Sütun)) <> "" Then
                    Sütun = 1
                    Satır = Satır + 10
                Else
                    Sütun = Sütun
                    Satır = Satır
                End If
            Next
        End If
    Next
 
Son:
    Set S1 = Nothing
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Nejdet ve Korhan hocam teşekkür ederim yardımlarınız için.
Nejdet hocam listeyi tek tek değilde otomatik doldurabilirmiyiz...
Korhan hocam sizin çalışmanız şu bakımdan uygun oldu otomatik doduruyor listeyi...
istediğim sonucu yakaladım fakat şöyle bir sıkıntım var...
(-)işaretini gördüğündede etiketi dolduruyor .(-) işaretinide görmesin yok saysın.....
sadece cümle olan etiketleri atayacağım (EG) ye.....
Hakkınızı ödeyemem....
 
tek tek doldurmuyor da test amaçlı Msgbox var.

MsgBox Sayfa.Cells(i, j).Offset(4, 1)

satırını silmek yeterli.
 
Nejdet ve korhan hocam
E1 .... E10 ile L1 ve L10 dosyalarında gördüğünüz 1 adet A4 e sığan etiketler..Her birinde alta doğru 4 grup daha gidiyor..Yani E1 de gördüğünüz dizilişten 4 adet A4 e sığacak kadar gine var.
Boyut sorunu olduğu için örnek amaçlı birer adet grup ekledim içlerine...
Dolayısıyla E1 .... E10 ile L1 ve L10 gruplarını aşağı doğru devam ediyor gibi düşünmemiz lazım

Şimdiden herşey için teşekkür ederim...
 
mancubus hocam teşekkür ederim. dediğiniz gibi silince NEJDET hocanın çalışmasıda otomatik yaptı..
Fakat NEJDET hocam 12 numaralı soruda açıkladığım detayları yansıtmıyor , görmüyor....
Örnek çalışmada gönderdiğim excelde aşağılara farklı bir ekleme yaptığımda onuda görmedi (EG) ye atmadı...
 
Nejdet hocam birde dikkat ettim makro sadece E1 i tanıyor....
E1 den E10 ve L1 den L10 hepsini taraması lazım.....
Örnek amaçlı olduğu için listeleri kısa tuttum..herbirinde 5 er gruplu düşünün listeyi...
Şuan her liste 1 gruplu kondu ...boyut nedeniyle
 
Merhaba,

Eklemiş olduğunuz dosyada " - " işaretini yazdığım şekilde kullanmışsınız. Eğer benim önerdiğim kodda tire işareti olan başka verileri aktarıyorsa aynı formatta yazılmamış demektir. Onları kontrol ediniz. Ayrıca ben eklediğiniz dosyaya alt satırlara gelecek şekilde grupları arttırarak önerdiğim kodu test ederek olumlu sonuç aldıktan foruma ekledim.

Not: Dosyanızın boyutunu küçültmek için foruma sıkıştırarak (WINRAR gibi programlarla) ekleyebilirsiniz.
 
Nejdet hocam
MsgBox Sayfa.Cells(i, j).Offset(4, 1) bu satırı sildikten sonra düzeldi hepsini atıyor..
Çalışma istediğim gibi fakat Sadece E1'i tarıyor (EG)ye ekliyor.....Aynı şekilde E1 den E10 a ve
L1 den L10 a tüm ekleri taraması gerekiyor....

ASIL İSTEDİĞİM ÖRNEK ÇALIŞMA EKTE...
 

Ekli dosyalar

Zahmet verdim arkadaşlar , çok özür dilerim ,,,,
Hata aslında bende ilk başta akıl edemedim winrar halinde eklemeyi....
boyut 500 geçmeyecek diyince takıldım....
dosyanın asıl hali mesaj 17 de
 
Korhan Ayhan' Alıntı:
Merhaba,

Eklemiş olduğunuz dosyada " - " işaretini yazdığım şekilde kullanmışsınız. Eğer benim önerdiğim kodda tire işareti olan başka verileri aktarıyorsa aynı formatta yazılmamış demektir. Onları kontrol ediniz. Ayrıca ben eklediğiniz dosyaya alt satırlara gelecek şekilde grupları arttırarak önerdiğim kodu test ederek olumlu sonuç aldıktan foruma ekledim.

Not: Dosyanızın boyutunu küçültmek için foruma sıkıştırarak (WINRAR gibi programlarla) ekleyebilirsiniz.
Genişletmek için tıkla ...

Korhan hocam hakkınızı helal edin benim hatam , amacım ''-'' vurgu yapmaktı.Asıl istediğim - işaretini görmeyecek yok sayacaktı.....
dediğiniz gibi dosyayı winrarla ekledim....
 
Merhaba,

Eklediğiniz son dosyanızı indirdim ve önerdiğim kodu denedim. Olumlu sonuç aldım. Sizde deneyin ve lütfen olmayan hücreyi adres vererek bildirin.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst