10/02/2021, 23:26
feraz
Berduş hocamızın 2.soru için çözümünü uygulayıp Dictionary ile yaptırdım.Extra sayfaya gerek kalmadı.Önceki sayfa eklenmesi sebebi sıralatmak içindi eğer ANA LİSTE sayfası sıralı gidiyorsa alttaki dosyada denenebilir.
Yukardaki kod yazdırma alanı için.Gerçi .Address olan satır olmasada çalışıyor.
Kod:
ShtHdf.PageSetup.PrintArea = ""
ShtHdf.PageSetup.PrintArea = ShtHdf.Range("A1").Resize(SonStr, sutun).Address
Yukardaki kod yazdırma alanı için.Gerçi .Address olan satır olmasada çalışıyor.
Sub ListeAktarDz()
Dim SonStr As Long, strx As Long, x, bul As Range
Dim Sht As Worksheet, i As Long, DzStr As Long, DzStn As Long
Dim ShtHdf As Worksheet
Dim Dizi() As Variant
Dim DiziKynk() As Variant
Const sutun As Byte = 12
Dim dic As Object
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)
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 = sutun Then
DzStn = 0
DzStr = DzStr + 1
End If
Next strx
ShtHdf.Range("A2").Resize(UBound(Dizi, 1) - 1, sutun).Value = Dizi
Set dic = CreateObject("Scripting.Dictionary")
For strx = LBound(DiziKynk) To UBound(DiziKynk)
If Not dic.exists(Left(DiziKynk(strx, 1), 4)) Then dic.Add Left(DiziKynk(strx, 1), 4), DiziKynk(strx, 1)
Next
For Each x In dic.items
Set bul = ShtHdf.Cells.Find(x, , , 1)
If Not bul Is Nothing Then
bul.Font.Bold = True: bul.Font.Color = vbRed
End If
Next
SonStr = ShtHdf.Cells(Sht.Rows.Count, "A").End(xlUp).Row
If SonStr < 2 Then GoTo son
ShtHdf.Range("A2").Resize(SonStr - 1, sutun).Borders.LineStyle = 1
ShtHdf.PageSetup.PrintArea = ""
ShtHdf.PageSetup.PrintArea = ShtHdf.Range("A1").Resize(SonStr, sutun).Address
son:
On Error Resume Next
Erase Dizi: Set Sht = Nothing: Set ShtHdf = Nothing: Set dic = Nothing: Set bul = Nothing
MsgBox "bitti"
End Sub