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
