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
#19
