Etiket basmada başarılı olamadım.

jajiyiko · 4 Eylül 2010

Ekteki dosyada sorunumu anlatmaya çalıştım.

Orion1 · 4 Eylül 2010

Dosyanız ektedir.

Kod:

Sub etiket_59()
Dim sh As Worksheet, sat As Long, i As Long, sut As Byte, k As Byte, j As Byte
Dim sut2 As Byte, say As Long, sat2 As Long
Sheets("Sayfa2").Select
Set sh = Sheets("Sayfa1")
sat = sh.Cells(65536, "A").End(xlUp).Row
Range("B4:K65536").Clear
If sat < 6 Then Exit Sub
sut2 = 3
sat2 = 4
say = 1
Application.ScreenUpdating = False
For i = 6 To sat
    sut = sh.Cells(i, 256).End(xlToLeft).Column
    If sut >= 8 Then
        If sh.Cells(i, "F").Value <> "" And sh.Cells(i, "G").Value <> "" And _
        IsDate(sh.Cells(i, "F").Value) And IsDate(sh.Cells(i, "G").Value) Then
            For k = 8 To sut
                If sh.Cells(i, k).Value <> "" And IsNumeric(sh.Cells(i, k).Value) Then
                    If sh.Cells(1, k).Value >= sh.Cells(i, "F").Value And _
                    sh.Cells(1, k).Value <= sh.Cells(i, "G").Value Then
                        For j = 1 To sh.Cells(i, k).Value
                            Cells(sat2, sut2 - 1).Value = "ETİKET" & say
                            Cells(sat2, sut2 - 1).Font.Bold = True
                            Cells(sat2 + 1, sut2 - 1).Value = "SAYIN:"
                            Cells(sat2 + 1, sut2 - 1).Font.Bold = True
                            Cells(sat2 + 1, sut2).Value = sh.Cells(i, "A").Value
                            Cells(sat2 + 1, sut2 + 2).Value = sh.Cells(i, "B").Value
                            Cells(sat2 + 3, sut2 - 1).Value = "ADRES:"
                            Cells(sat2 + 3, sut2 - 1).Font.Bold = True
                            Cells(sat2 + 3, sut2).Value = sh.Cells(i, "C").Value
                            Cells(sat2 + 3, sut2 + 2).Value = sh.Cells(i, "D").Value
                            Cells(sat2 + 5, sut2 - 1) = "NO:"
                            Cells(sat2 + 5, sut2 - 1).Font.Bold = True
                            Cells(sat2 + 5, sut2).Value = sh.Cells(i, "E").Value
                            say = say + 1
                            If sut2 = 3 Then
                                sut2 = 9
                                Else
                                sut2 = 3
                                sat2 = sat2 + 9
                            End If
                        Next j
                    End If
                End If
            Next k
        End If
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Etiketler çıkarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

jajiyiko · 4 Eylül 2010

Sayın Gizlen ilginize teşekkür ederim.

Gönderdiğiniz dosyayı inceledim. Bana lazım olan şu: Ben yazıcıdan yazdıracağım için bunları sadece sayfada 4 adet etiket olacak her 4 etiketi bir sayfada yazdıracağım.Bunu yapabiliyorum. Ancak Sayfa1 de hizalarındaki rakam kadar o kayıtlardan etiket oluşacak.

Yani adı Ahmet olanın tarih sütununda 2 varsa ahmetin iki tane etiketi olacak.Sonrada diğer ismin karşısında rakam varsa onun da rakam kadar etiketi yazılacak.Bu arka arkaya devam edecek.

Anlatabildimmi bilmiyorum.

Teşekkür ederim.

Not: Bir mesajım Forum Kurallarına Uymayan Başlıklar bölümüne taşınmış. Ben o mesajda "Lütfen" kelimesini yalvarmak amacıyla değil, bir nezaket gereği kullanmıştım.

Orion1 · 5 Eylül 2010

jajiyiko' Alıntı:
Sayın Gizlen ilginize teşekkür ederim.

Gönderdiğiniz dosyayı inceledim. Bana lazım olan şu: Ben yazıcıdan yazdıracağım için bunları sadece sayfada 4 adet etiket olacak her 4 etiketi bir sayfada yazdıracağım.Bunu yapabiliyorum. Ancak Sayfa1 de hizalarındaki rakam kadar o kayıtlardan etiket oluşacak.

Yani adı Ahmet olanın tarih sütununda 2 varsa ahmetin iki tane etiketi olacak.Sonrada diğer ismin karşısında rakam varsa onun da rakam kadar etiketi yazılacak.Bu arka arkaya devam edecek.

Anlatabildimmi bilmiyorum.

Teşekkür ederim.

Not: Bir mesajım Forum Kurallarına Uymayan Başlıklar bölümüne taşınmış. Ben o mesajda "Lütfen" kelimesini yalvarmak amacıyla değil, bir nezaket gereği kullanmıştım.

Yalnız ilk mesajınızdaki eklediğiniz dosya ve isteğiniz ile şimdi son mesajınızda yolladığınız ve eklediğiniz dosya ve istek farklı.
Ben ilk mesajınaza ve dosya örneğinize göre dosyayı yaptım.
İlk dosyada sayfa1 de F ve G sütunlarında tarihler vardı.
Ve o tarihler arasındaki 1nci satırdaki tarileri uyanları almamızı istediniz.
Oysa şimdi yoladığınız dosyada F ve G tarihlerinde veri yok.
Böyle bir istekte yok.
İlk yolladığınız dosyada 9 tane etiket sayfa2'de yazmışsınız örnek olarak.Oysa şimdi yolladığınızda 4 etiket istiyorum diyorsunuz.
Bu gibi röstarasyonlar bitmez.
Önce ne yapacağınız karar verin kafanızda tasarlayın sonra istekliriniz sıralayın.
Şimdi ben bu son istediğiniz duruma göre tekrardan uğraşıp yaptıktan sonra ne malum bu şekilde değil başka şekilde istiyorum gibisinden başka bir istekle tekrardan dönmeyeceğinizi!
Ben bundan sonrası için yokum.
Başka arkadaşlardan yardım alınız.

jajiyiko · 5 Eylül 2010

Sayın Gizlen

Şimdi gönderdiğim dosya doğrusu. Önceki başka bir arkadaşın gönderdiği dosya imiş. özür dilerim.

Orion1 · 5 Eylül 2010

Dosyanz ektedir.

Kod:

Option Base 1
Sub etiket_59()
Dim sh As Worksheet, sat As Long, i As Long, sut As Byte, k As Byte, j As Byte
Dim sut2 As Byte, say As Long, sat2 As Long, myarr(), a As Long
Sheets("Sayfa2").Select
Set sh = Sheets("Sayfa1")
sat = sh.Cells(65536, "A").End(xlUp).Row
Range("B4:K65536").Clear
If sat < 6 Then Exit Sub
ReDim myarr(1 To 5, 1 To 65536)
For i = 6 To sat
    sut = sh.Cells(i, 256).End(xlToLeft).Column
    If sut >= 8 Then
        For k = 6 To sut
            If sh.Cells(i, k).Value <> "" And IsNumeric(sh.Cells(i, k).Value) Then
                For j = 1 To sh.Cells(i, k).Value
                    a = a + 1
                    myarr(1, a) = sh.Cells(i, "A").Value
                    myarr(2, a) = sh.Cells(i, "B").Value
                    myarr(3, a) = sh.Cells(i, "C").Value
                    myarr(4, a) = sh.Cells(i, "D").Value
                    myarr(5, a) = sh.Cells(i, "E").Value
                Next j
            End If
        Next k
    End If
Next i
If a = 0 Then
    Erase myarr: Exit Sub
End If
On Error GoTo son
ReDim Preserve myarr(1 To 5, 1 To a)
Application.ScreenUpdating = False
ActiveSheet.PageSetup.PrintArea = "B4:K18"
say = 1
i = 0
Do While i <= UBound(myarr, 2)
    sat2 = 4
    sut2 = 3
    Do While i <= UBound(myarr, 2) And say <= 4
        i = i + 1
        Cells(sat2, sut2 - 1).Value = "ETİKET" & i
        Cells(sat2, sut2 - 1).Font.Bold = True
        Cells(sat2 + 1, sut2 - 1).Value = "SAYIN:"
        Cells(sat2 + 1, sut2 - 1).Font.Bold = True
        Cells(sat2 + 1, sut2).Value = myarr(1, i)
        Cells(sat2 + 1, sut2 + 2).Value = myarr(2, i)
        Cells(sat2 + 3, sut2 - 1).Value = "ADRES:"
        Cells(sat2 + 3, sut2 - 1).Font.Bold = True
        Cells(sat2 + 3, sut2).Value = myarr(3, i)
        Cells(sat2 + 3, sut2 + 2).Value = myarr(4, i)
        Cells(sat2 + 5, sut2 - 1) = "NO:"
        Cells(sat2 + 5, sut2 - 1).Font.Bold = True
        Cells(sat2 + 5, sut2).Value = myarr(5, i)
        say = say + 1
        If sut2 = 3 Then
            sut2 = 9
            Else
            sut2 = 3
            sat2 = 13
        End If
    Loop
    say = 1
    ActiveSheet.PrintOut
Loop
Erase myarr
Application.ScreenUpdating = True
MsgBox "Etiketler çıkarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
Exit Sub
son:
Erase myarr
Application.ScreenUpdating = True
End Sub

jajiyiko · 5 Eylül 2010

Sayın Gizlen!

İlginize gerçekten teşekkür ederim ama ben problemimi anlatamadım herhalde .Atıyorum 30.09.2010 tarihi ile 05.10.2010 tarihi arasındakileri etiket olarak basacağız. Mesela 9.satırdaki Veli'nin karşısındaki 30.09.2010 tarihli sütununda 2 var o zaman ilk iki etiket Veliye ait sonra 30.09.2010 tarihini kontrole devam ediyoruz. Mesela 15.satırda Mehmet in karşısında da 1 var o zaman 3. etiket mehmet e ait olacak. Sonra 26. satırdaki ahmetin karşısında 2 var , 1 adet 4.etiket te ahmete ait olacak .Böylece 4 adet etiket hazır olacak bu yazdırılacak sonra bu etiket alanları silinecek ,ahmete ait diğer etiket etiket sayfasında 1. etiket olacak ve böyle devam edecek.

tahsinanarat · 5 Eylül 2010

jajiyiko' Alıntı:
Sayın Gizlen!

İlginize gerçekten teşekkür ederim ama ben problemimi anlatamadım herhalde .Atıyorum 30.09.2010 tarihi ile 05.10.2010 tarihi arasındakileri etiket olarak basacağız. Mesela 9.satırdaki Veli'nin karşısındaki 30.09.2010 tarihli sütununda 2 var o zaman ilk iki etiket Veliye ait sonra 30.09.2010 tarihini kontrole devam ediyoruz. Mesela 15.satırda Mehmet in karşısında da 1 var o zaman 3. etiket mehmet e ait olacak. Sonra 26. satırdaki ahmetin karşısında 2 var , 1 adet 4.etiket te ahmete ait olacak .Böylece 4 adet etiket hazır olacak bu yazdırılacak sonra bu etiket alanları silinecek ,ahmete ait diğer etiket etiket sayfasında 1. etiket olacak ve böyle devam edecek.

Sn. jajiyiko; örneğinize bakıldığında 30.09.2010 sutununda hiç bir rakam yok, buna göre düzenlendiğinde bence yine beyenmeyeceksiniz. Konuyu bende başından beri takip ediyorum, siz sutundaki mesala 30.09.2010 un bulunduğu k sutunundaki sayılar kadarmı etiket olsun istiyorsunuz, (tabiki k sutununda örnekte hiç bir rakam yok), ne istediğiniz inanın ki çok zor anlaşılıyor.

jajiyiko · 6 Eylül 2010

Sayın tahsinarat !

Yeni bir dosya gönderiyorum orada tekrar anlatmaya çalıştım.

jajiyiko · 6 Eylül 2010

Sayın tahsinanarat size ve Sayın Evren Gizlen ' e gerçekten teşekkür ediyorum ilginiz için. Sayın Evren Gizlen'in aşağıdaki adreste verdiği Tekrarlı yazı59 isimli dosya benim işimi görecek gibi görünüyor.Ben onun üzerinde çalışarak bir şeyler yapmaya uğraşacağım.O dosyadaki "Yazılacak" sütunundaki rakamların yerine bendeki isimler gelecek,"tekrar" sütunundaki rakamlar da benim etiket sayım olacak.

http://www.excel.web.tr/showthread.php?t=87535

Çok teşekkürler.

Kolay gelsin

tahsinanarat · 6 Eylül 2010

dosyanız ekte

anladığım kadarıyla bir tarih aralığı belirliyeceksiniz ki o tarih aralığı toplamı kadar etiket basmak istiyorsunuz, Sn. Evren Gizlen hocamın kodlarının aynısını ben saadece etiket sayısı kadar uygulanması için uyarlamaya çalıştım, incelermisiniz.

Korhan Ayhan · 6 Eylül 2010

Selamlar,

Alternatif olarak ekteki örnek dosyayı incelermisiniz.

Kullanılan kod; (Boş bir modüle uygulayın.)

Kod:

Option Explicit
 
Sub ETİKET_YAZ()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim İLK_TARİH As Date, SON_TARİH As Date
    Dim X1 As Byte, X2 As Long, X3 As Byte
    Dim SATIR As Byte, SÜTUN As Byte
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("ETIKET")
    
    İLK_TARİH = S1.Range("B1")
    SON_TARİH = S1.Range("B2")
    
    S2.Range("C7,C9,C11,C13,C21,C23,C25,C27").ClearContents
    S2.Range("G7,G9,G11,G13,G21,G23,G25,G27").ClearContents
    
    For X1 = 5 To S1.Range("IV1").End(1).Column
        If S1.Cells(1, X1) >= İLK_TARİH And S1.Cells(1, X1) <= SON_TARİH Then
            For X2 = 6 To S1.Range("A65536").End(3).Row
                If S1.Cells(X2, X1) <> "" And IsNumeric(S1.Cells(X2, X1)) Then
                    For X3 = 1 To S1.Cells(X2, X1)
                        If S2.Range("C7") = "" Then
                            SATIR = 7
                            SÜTUN = 3
                        ElseIf S2.Range("G7") = "" Then
                            SATIR = 7
                            SÜTUN = 7
                        ElseIf S2.Range("C21") = "" Then
                            SATIR = 21
                            SÜTUN = 3
                        ElseIf S2.Range("G21") = "" Then
                            SATIR = 21
                            SÜTUN = 7
                        End If
                        S2.Cells(SATIR, SÜTUN) = S1.Cells(X2, 1)
                        S2.Cells(SATIR + 2, SÜTUN) = S1.Cells(X2, 2)
                        S2.Cells(SATIR + 4, SÜTUN) = S1.Cells(X2, 3)
                        S2.Cells(SATIR + 6, SÜTUN) = S1.Cells(X2, 4)
                            
                        If SATIR = 7 And SÜTUN = 3 Then
                            SATIR = 7
                            SÜTUN = 7
                        ElseIf SATIR = 7 And SÜTUN = 7 Then
                            SATIR = 21
                            SÜTUN = 3
                        ElseIf SATIR = 21 And SÜTUN = 3 Then
                            SATIR = 21
                            SÜTUN = 7
                        ElseIf SATIR = 21 And SÜTUN = 7 Then
                            S2.PrintOut , , 1
                            S2.Range("C7,C9,C11,C13,C21,C23,C25,C27").ClearContents
                            S2.Range("G7,G9,G11,G13,G21,G23,G25,G27").ClearContents
                        End If
                    Next
                End If
            Next
        End If
    Next
    
    If S2.Range("C7") <> "" Then S2.PrintOut , , 1
    S2.Range("C7,C9,C11,C13,C21,C23,C25,C27").ClearContents
    S2.Range("G7,G9,G11,G13,G21,G23,G25,G27").ClearContents
 
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

jajiyiko · 6 Eylül 2010

Sayın tahsinanarat ve sayın Korhan Ayhan her ikinizede sonsuz teşekkürler.Sayın tahsinanarat yaptığınız doğru fakat yanlızca sayfada 4 adet olması gerekirdi. Sayın Korha beyin yaptığı tamamen benim istediğim gibi.

Her ikinizede sonsuz teşekkür ederim,emek sarfettiniz

Sağolun

jajiyiko · 6 Eylül 2010

Sayın Korhan Ayhan gönderdiğiniz dosya benim istediğim gibi.Ancak ben kendi dosyama adapte edemedim. Dosyamdaki kayıtları azaltarak size gönderiyorum.Burada düzenleme yapabilirmisiniz?
Teşekkür ederim.

Korhan Ayhan · 7 Eylül 2010

Selamlar,

Keşke bu dosyanızı EN BAŞTAN ekleseydiniz. Boşuna bu kadar kod yazılmazdı ve zaman harcanmazdı.

Aşağıdaki kodu deneyiniz.

Kod:

Option Explicit
 
Sub ETİKET_YAZ()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim İLK_TARİH As Date, SON_TARİH As Date
    Dim X1 As Byte, X2 As Long, X3 As Byte
    Dim SATIR As Byte, SÜTUN As Byte
 
    Set S1 = Sheets("EKICI")
    Set S2 = Sheets("GUN")
 
    İLK_TARİH = S1.Range("B1")
    SON_TARİH = S1.Range("B2")
 
    S2.Range("B9:C9,B11:C11,B13:C13,D14,F14:H14,B32:C32,B34:C34,B36:C36,D37,F37:H37").ClearContents
    S2.Range("K9:L9,K11:L11,K13:L13,M14,O14:Q14,K32:L32,K34:L34,K36:L36,M37,O37:Q37").ClearContents
 
    For X1 = 18 To S1.Range("IV1").End(1).Column
        If S1.Cells(1, X1) >= İLK_TARİH And S1.Cells(1, X1) <= SON_TARİH Then
            For X2 = 7 To S1.Range("A65536").End(3).Row
                If S1.Cells(X2, X1) <> "" And IsNumeric(S1.Cells(X2, X1)) Then
                    For X3 = 1 To S1.Cells(X2, X1)
                        If S2.Range("B9") = "" Then
                            SATIR = 9
                            SÜTUN = 2
                        ElseIf S2.Range("K9") = "" Then
                            SATIR = 9
                            SÜTUN = 11
                        ElseIf S2.Range("B32") = "" Then
                            SATIR = 32
                            SÜTUN = 2
                        ElseIf S2.Range("K32") = "" Then
                            SATIR = 32
                            SÜTUN = 11
                        End If
                        S2.Cells(SATIR, SÜTUN) = S1.Cells(X2, "G")
                        S2.Cells(SATIR + 2, SÜTUN) = S1.Cells(X2, "H")
                        S2.Cells(SATIR + 4, SÜTUN) = S1.Cells(1, X1)
                        S2.Cells(SATIR + 5, SÜTUN + 2) = S1.Cells(X2, "F")
                        S2.Cells(SATIR + 5, SÜTUN + 4) = S1.Cells(X2, "G") & " " & S1.Cells(X2, "H")
 
                        If SATIR = 9 And SÜTUN = 2 Then
                            SATIR = 9
                            SÜTUN = 11
                        ElseIf SATIR = 9 And SÜTUN = 11 Then
                            SATIR = 32
                            SÜTUN = 2
                        ElseIf SATIR = 32 And SÜTUN = 2 Then
                            SATIR = 32
                            SÜTUN = 11
                        ElseIf SATIR = 32 And SÜTUN = 11 Then
                            S2.PrintOut , , 1
                            S2.Range("B9:C9,B11:C11,B13:C13,D14,F14:H14,B32:C32,B34:C34,B36:C36,D37,F37:H37").ClearContents
                            S2.Range("K9:L9,K11:L11,K13:L13,M14,O14:Q14,K32:L32,K34:L34,K36:L36,M37,O37:Q37").ClearContents
                        End If
                    Next
                End If
            Next
        End If
    Next
 
    If S2.Range("B9") <> "" Then S2.PrintOut , , 1
    S2.Range("B9:C9,B11:C11,B13:C13,D14,F14:H14,B32:C32,B34:C34,B36:C36,D37,F37:H37").ClearContents
    S2.Range("K9:L9,K11:L11,K13:L13,M14,O14:Q14,K32:L32,K34:L34,K36:L36,M37,O37:Q37").ClearContents
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

jajiyiko · 7 Eylül 2010

Sayın Korhan Ayhan sizden yüzlerce defa özür dilerim. Ben biraz da birşeyler öğrenmek amacıyla biraz farklı bir dosya hazırlamıştım. Ancak başaramadım. Bu ramazan da size de yük oldum.

Teşekkür ederim.

Hakkınız geçti bana,lütfen hakkınızı helal edin.

Korhan Ayhan · 7 Eylül 2010

Selamlar,

Rica ederim. Hakkımız varsa helal olsun.

Etiket basmada başarılı olamadım.

jajiyiko

Ekli dosyalar

Orion1

Uzman

Ekli dosyalar

jajiyiko

Ekli dosyalar

Orion1

Uzman

jajiyiko

Orion1

Uzman

Ekli dosyalar

jajiyiko

tahsinanarat

jajiyiko

Ekli dosyalar

jajiyiko

tahsinanarat

Ekli dosyalar

Korhan Ayhan

Administrator

Ekli dosyalar

jajiyiko

jajiyiko

Ekli dosyalar

Korhan Ayhan

Administrator

Ekli dosyalar

jajiyiko

Korhan Ayhan

Administrator