RE: Dikey Verileri Yatay Olarak Sayfa Sayfa Yazdırma Sorunu - ercansahiner61 - 09/02/2021
Hocam hayırlı sabahlar, çok rahatsız ettim biliyorum ama;
aktarılan listede dosya numaraları başında yıl bilgisi mevcut benim istediğim her yılın ilk numarasını içeren veri hücresinin renklendirilmesi mümkün müdür. ilgilenirseniz memmun olurum.
daha önce bahsettiğim gibi kod güzel çalışıyor ancak en son boş satırı biçimlendirdiği için veri olmasa dahi görülüyor, bunu göstermememiz mümkünmüdür.
örnek verecek olursak, 2011/899, 2012/342, 2013/79 gibi o yıla ait ilk numarayı renklendirebilirsek kolay görme açısından büyük kolaylık olacak. teşekkür ederim.
RE: Dikey Verileri Yatay Olarak Sayfa Sayfa Yazdırma Sorunu - feraz - 09/02/2021
Sonuç nasıl çıkacak bunu sayfada gösterebilirmisiniz renklendirmelerde dahil.
Ona göre uğraşalım değilse anlayamadım.
Dosyayı eklemeniz için konuyu geri cevapsızlara taşıdım.Çalışan koda göre ekleyin ve akşam bakabilirim eğer başka biri çözmezse.
RE: Dikey Verileri Yatay Olarak Sayfa Sayfa Yazdırma Sorunu - ercansahiner61 - 09/02/2021
1- Her yıla ait çok sayıda dosya numarası var. Ekte gönderdiğin çalışmada gösterildiği gibi her yılın başlangıcındaki ilk sayı (en küçük sayı) Koyu yazı tipi ve renkli göstersin.
örnek verecek olursan, 2011 yılının ilk en küçük sayısı 2011/899, 2012 yılının ilk en küçük verisi 2012/342, 2013/79, 2014/41 ..........2019/2 gibi,
2-Eğer mümkünse her yıla ait dosya numaraları bitiminde, sonraki gelen yeni yıla ait dosya numarası bir alt yeni satırdan başlatılabilirrmi.???
3-Sıralama listesindeki aktarma işleminden sonraki son satış boş olmasına rağmen biçim olduğu için boş görünüyor. gösterilmemesi mümkün müdür.
RE: Dikey Verileri Yatay Olarak Sayfa Sayfa Yazdırma Sorunu - feraz - 10/02/2021
2.soruyu anlamadım.
Diğerleri bitti.
Kodların kısa olması için ve çözümün kolay yapılabilmesi için Ayarlar adında bir sayfa ekledim.Bu sayfada işlemleri yaptırıp temizlettim en sonda.
Ayrıca yazdırma alanınıda dinamik yaptırdım.Hatalar olursa yazın düzeltelim.
PHP Kod:
Sub Kopyala() Dim syfAyarlar As Worksheet Dim Sht As Worksheet Dim sonAna As Long Set syfAyarlar = ThisWorkbook.Sheets("Ayarlar") Set Sht = ThisWorkbook.Worksheets("ANA LİSTE") sonAna = Sht.Range("A" & Rows.Count).End(3).Row If sonAna < 2 Then GoTo son If WorksheetFunction.CountA(Sht.Range("A2:A" & Rows.Count)) = 0 Then GoTo son syfAyarlar.Range("A:C").Clear Sht.Range("A2:A" & sonAna).Copy syfAyarlar.Range("A1").PasteSpecial xlPasteValues ayir syfAyarlar syfAyarlar.Range("A:B").Sort key1:=syfAyarlar.Range("A1"), key2:=syfAyarlar.Range("B1") Birlestir syfAyarlar syfAyarlar.Range("A:C").Clear son: Application.CutCopyMode = False Set syf = Nothing Set Sht = Nothing End Sub
Sub ayir(syf As Worksheet) syf.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _ :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True End Sub
Sub Birlestir(syf As Worksheet) Dim i As Long, say As Long, sonAyarlar As Long say = 1 Application.ScreenUpdating = False With syf sonAyarlar = .Range("A" & Rows.Count).End(3).Row .Cells(1, 3).Value = .Cells(1, 1).Value & "/" & .Cells(1, 2).Value For i = 2 To sonAyarlar - 1 If .Cells(i, 1).Value <> .Cells(i + 1, 1).Value Then say = say + 1 .Cells(say, 3).Value = .Cells(i + 1, 1).Value & "/" & .Cells(i + 1, 2).Value End If Next sonAyarlar = .Range("C" & Rows.Count).End(3).Row bul syf, ThisWorkbook.Worksheets("SIRALAMA"), sonAyarlar End With Application.ScreenUpdating = True End Sub
Sub bul(ByVal syf As Worksheet, ByVal syfSiralama As Worksheet, ByVal son As Long) Dim i As Long, bul As Range For i = 1 To son aranan = syf.Cells(i, 3).Value Set bul = syfSiralama.Cells.Find(syf.Cells(i, 3).Value, , , 1) If Not bul Is Nothing Then bul.Font.Bold = True Next Set bul = Nothing End Sub
Sub ListeAktarDz() Dim SonStr As Long Dim Sht As Worksheet Dim ShtHdf As Worksheet Dim Dizi() As Variant Dim DiziKynk() As Variant Const sutun As Byte = 12 Set Sht = ThisWorkbook.Worksheets("ANA LİSTE") Set ShtHdf = ThisWorkbook.Worksheets("SIRALAMA") ShtHdf.Range("A2", ShtHdf.Cells(Rows.Count, "XFD")).Clear SonStr = Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row If SonStr < 2 Then GoTo son If SonStr = 2 Then ShtHdf.Range("A2").Value = Sht.Range("A2").Value GoTo son End If StrSay = (SonStr - 1) \ sutun + 1 ReDim Dizi(StrSay, sutun) DiziKynk = Sht.Range("A2:A" & SonStr) i = 0 For StrX = LBound(DiziKynk) To UBound(DiziKynk) Dizi(((StrX - 1) \ sutun), (StrX - 1) Mod sutun) = DiziKynk(StrX, 1) Next StrX ShtHdf.Range("A2").Resize(UBound(Dizi, 1) - 1, sutun).Value = Dizi ShtHdf.Range("A2").Resize(UBound(Dizi, 1) - 1, sutun).Borders.LineStyle = 1 ShtHdf.PageSetup.PrintArea = "$A$1:$L$" & UBound(Dizi, 1) 'sayfa yazdirma alani icin otomatik yapildi son: On Error Resume Next Erase Dizi: Set Sht = Nothing: Set ShtHdf = Nothing Kopyala MsgBox "bitti" End Sub
RE: Dikey Verileri Yatay Olarak Sayfa Sayfa Yazdırma Sorunu - berduş - 10/02/2021
2. isteğiniz için aşağıdaki kodu dener misiniz?
fırsat bulunca diğerlerini de yapmaya çalışırım
Sub ListeAktarDz()
Dim SonStr As Long
Dim Sht As Worksheet
Dim ShtHdf As Worksheet
Dim Dizi() As Variant
Dim DiziKynk() As Variant
Dim DzStr As Long, DzStn As Byte
Const sutun As Byte = 12
Set Sht = ThisWorkbook.Worksheets("ANA LİSTE")
Set ShtHdf = ThisWorkbook.Worksheets("SIRALAMA")
ShtHdf.Range("A2", ShtHdf.Cells(Rows.Count, "XFD")).Clear
SonStr = Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row
If SonStr < 2 Then GoTo son
If SonStr = 2 Then
ShtHdf.Range("A2").Value = Sht.Range("A2").Value
GoTo son
End If
TmpYnYil = Left(Sht.Range("A2"), 4)
DzStr = 0
DzStn = 0
StrSay = ((SonStr - 1) \ sutun) + 1 + Left(Sht.Range("A" & SonStr), 4) - Left(Sht.Range("A2"), 4) + 1
ReDim Dizi(StrSay, sutun)
DiziKynk = Sht.Range("A2:A" & SonStr)
i = 0
For StrX = LBound(DiziKynk) To UBound(DiziKynk)
If TmpYnYil <> Left(DiziKynk(StrX, 1), 4) Then
DzStr = IIf(DzStn > 0, DzStr + 1, DzStr)
DzStn = 0
TmpYnYil = Left(DiziKynk(StrX, 1), 4)
End If
Dizi(DzStr, DzStn) = DiziKynk(StrX, 1)
DzStn = DzStn + 1
If DzStn = 12 Then
DzStn = 0
DzStr = DzStr + 1
End If
Next StrX
ShtHdf.Range("A2").Resize(UBound(Dizi, 1), sutun).Value = Dizi
ShtHdf.Range("A2").Resize(UBound(Dizi, 1), sutun).Borders.LineStyle = 1
son:
' On Error Resume Next
Erase Dizi: Set Sht = Nothing: Set ShtHdf = Nothing
MsgBox "bitti"
End Sub
RE: Dikey Verileri Yatay Olarak Sayfa Sayfa Yazdırma Sorunu - berduş - 10/02/2021
dilerim işinize yarar
iyi çalışmalar
Sub ListeAktarDz()
Dim SonStr As Long
Dim Sht As Worksheet
Dim ShtHdf As Worksheet
Dim Dizi() As Variant
Dim DiziKynk() As Variant
Dim DzStr As Long, DzStn As Byte
Dim RngBold As String
Dim RngBoldDz() As String
Const sutun As Byte = 12
RngBold = "A2"
Set Sht = ThisWorkbook.Worksheets("ANA LİSTE")
Set ShtHdf = ThisWorkbook.Worksheets("SIRALAMA")
ShtHdf.Range("A2", ShtHdf.Cells(Rows.Count, "XFD")).Clear
SonStr = Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row
If SonStr < 2 Then GoTo son
If SonStr = 2 Then
ShtHdf.Range("A2").Value = Sht.Range("A2").Value
GoTo son
End If
TmpYnYil = Left(Sht.Range("A2"), 4)
DzStr = 0
DzStn = 0
StrSay = ((SonStr - 1) \ sutun) + 1 + Left(Sht.Range("A" & SonStr), 4) - Left(Sht.Range("A2"), 4) + 1
ReDim Dizi(StrSay, sutun)
DiziKynk = Sht.Range("A2:A" & SonStr)
i = 0
For StrX = LBound(DiziKynk) To UBound(DiziKynk)
If TmpYnYil <> Left(DiziKynk(StrX, 1), 4) Then
DzStr = IIf(DzStn > 0, DzStr + 1, DzStr)
DzStn = 0
RngBold = RngBold & ", A" & DzStr + 2
TmpYnYil = Left(DiziKynk(StrX, 1), 4)
End If
Dizi(DzStr, DzStn) = DiziKynk(StrX, 1)
DzStn = DzStn + 1
If DzStn = 12 Then
DzStn = 0
DzStr = DzStr + 1
End If
Next StrX
ShtHdf.Range("A2").Resize(UBound(Dizi, 1), sutun).Value = Dizi
SonStr = ShtHdf.Cells(ShtHdf.Rows.Count, "A").End(xlUp).Row + 1
ShtHdf.Range("A2").Resize(UBound(Dizi, 1), sutun).Borders.LineStyle = 1
ShtHdf.Range("A" & SonStr & ":L" & UBound(Dizi, 1) + 2).Clear
RngBoldDz = Split(RngBold, ",")
Dim Item As Variant
For Each Item In RngBoldDz
ShtHdf.Range(Item).Font.Bold = True
ShtHdf.Range(Item).Font.Color = vbRed
Next Item
son:
' On Error Resume Next
Erase Dizi: Set Sht = Nothing: Set ShtHdf = Nothing
MsgBox "bitti"
End Sub
|