RE: Dikey Verileri Yatay Olarak Sayfa Sayfa Yazdırma Sorunu - berduş - 05/02/2021
Yok onun farkındayım ama sonradan hep bir şey çıkıyor eklemeyi unutuyorum) )
RE: Dikey Verileri Yatay Olarak Sayfa Sayfa Yazdırma Sorunu - feraz - 05/02/2021
Buda benden olsun.
Sub AKTAR()
Dim Sht As Worksheet, ShtHdf As Worksheet
Dim i As Long, SonStr As Long, say As Long
Application.ScreenUpdating = False
Set Sht = ThisWorkbook.Worksheets("ANA LİSTE")
Set ShtHdf = ThisWorkbook.Worksheets("SIRALAMA")
ShtHdf.Range("A2:L" & Rows.Count).Clear
SonStr = Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row
say = 2
If WorksheetFunction.CountA(Sht.Range("A2:A" & Rows.Count)) = 0 Then GoTo son
For i = 2 To SonStr Step 12
ShtHdf.Range("A" & say & ":L" & say).Value = Application.Transpose(Sht.Range("A" & i & ":A" & i + 12).Value)
say = say + 1
Next
MsgBox "bitti"
son:
Application.ScreenUpdating = True
Set Sht = Nothing: Set ShtHdf = Nothing
End Sub
RE: Dikey Verileri Yatay Olarak Sayfa Sayfa Yazdırma Sorunu - feraz - 05/02/2021
sayin @berduş hocam kodunuzu biraz düzenledim.
Eğer son satır küçük 2 ise ekledim.
Ve en önemliside ANA LİSTE sayfasında sadece A2 de veri olursa For StrX = LBound(DiziKynk) To UBound(DiziKynk) bu satırda hata verirdi.
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, sutun)).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), sutun) = Dizi
son:
On Error Resume Next
Erase Dizi: Set Sht = Nothing: Set ShtHdf = Nothing
MsgBox "bitti"
End Sub
Çizgi içinde resimdeki gibi ilgilikodu ekleyin son koda.
ShtHdf.Range("A2").Resize(UBound(Dizi, 1), sutun).Borders.LineStyle = 1
RE: Dikey Verileri Yatay Olarak Sayfa Sayfa Yazdırma Sorunu - berduş - 05/02/2021
Galiba her 38 satırda 1 çerçeve isteniyor
Geri dönüşü bekliyorum tam olarak ne istendiğini anlamak için
RE: Dikey Verileri Yatay Olarak Sayfa Sayfa Yazdırma Sorunu - feraz - 05/02/2021
Kodu düzenledim. Const sutun As Byte = 12 burdaki 12 yerine ne gelirse o kadar sütun olur.
Benden bu kadar ![Img-grin Img-grin](https://accesstr.net/images/smilies/img-grin.gif)
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), 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 - feraz - 06/02/2021
Üye beğenmedi heralde bizi Halil hocam
|