veyselemre
Özel Üye
- Katılım
- 9 Mart 2005
- Mesajlar
- 3,642
- Excel Vers. ve Dili
- Pro Plus 2021
Soruyu Halit Bey, gayet güzel cevaplamış, bir alternatif de ben yaptım.
Ekli dosyalar
-
31.9 KB Görüntüleme: 66
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
bu kodu denermisiniztablom tam olarak bu
Sub Makro1()
git = ActiveSheet.Name
For i = 2 To WorksheetFunction.CountA(Worksheets("toplam").Range("Q2:Q65000")) + 1
For s = 1 To Len(Worksheets("toplam").Cells(i, 17).Value)
deger5 = deger5 & "@"
Next s
yer = Format(Worksheets("toplam").Cells(i, 17).Value, deger5)
deger = 0
For r = 1 To ActiveWorkbook.Sheets.Count
If Sheets(r).Name = yer Then
deger = 1
End If
Next r
deger5 = ""
If deger <> 1 Then
Sheets.Add
On Error Resume Next
Sheets(ActiveSheet.Name).Name = yer
Sheets(yer).Move After:=Sheets(ActiveWorkbook.Sheets.Count)
For n = 2 To WorksheetFunction.CountA(Worksheets("toplam").Range("Q2:Q65000")) + 1
If Worksheets("toplam").Cells(n, 17).Value <> "" Then
If Worksheets("toplam").Cells(n, 17).Value = Worksheets("toplam").Cells(i, 17).Value Then
sat = WorksheetFunction.CountA(Worksheets(yer).Range("C2:C65000")) + 2
For m = 1 To 18
Worksheets(yer).Cells(1, m).Value = Worksheets("toplam").Cells(1, m).Value
Worksheets(yer).Cells(1, m).Interior.ColorIndex = 4
Worksheets(yer).Cells(1, m).Font.Bold = True
If m = 1 Then
Worksheets(yer).Cells(1, m).Rows("1:1").RowHeight = 25.5
End If
Next m
For j = 2 To 18
Worksheets(yer).Cells(sat, j).Value = Worksheets("toplam").Cells(n, j).Value
Next j
Worksheets(yer).Cells(sat, 1).Value = sat - 1
sat = sat + 1
End If
End If
Next n
Worksheets(yer).Columns("A").ColumnWidth = 4
Worksheets(yer).Columns("B").ColumnWidth = 10
Worksheets(yer).Columns("C").ColumnWidth = 19
Worksheets(yer).Columns("D").ColumnWidth = 16
Worksheets(yer).Columns("E:G").ColumnWidth = 12
Worksheets(yer).Columns("H").ColumnWidth = 4
Range("A1:R" & sat - 1).Select
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
Selection.Font.Size = 8
Selection.Font.Name = "Tahoma"
Selection.Font.FontStyle = "Normal"
Range("A1").Select
End If
Next i
Sheets(git).Select
End Sub
Sub Makro2()
If ActiveWorkbook.Sheets.Count >= 3 Then
git = ActiveSheet.Name
Dim myArray() As Variant
r = 0
For i = 1 To Sheets.Count
If Sheets(i).Name = "toplam" Then
r = r + 1
'----------------------------------- bu bölüme silinmeyecek sayfaları ekleme yapabilirsiniz.
ElseIf Sheets(i).Name = "deneme" Then
r = r + 1
'-------------------------------------
Else
ReDim Preserve myArray(i - (1 + r))
myArray(i - (1 + r)) = i
End If
Next i
Sheets(myArray).Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets(git).Select
End If
End Sub
bu hatatı verdi debug kısmında
run time error "9"
subscript aut of range