- Katılım
- 25 Nisan 2008
- Mesajlar
- 151
- Excel Vers. ve Dili
- excel 2003 türkçe
Selamlar (Bibliografya) isimli bir veri sayfam var. C stünu yazar isimi, E stunu konu ismi
C ve E stunlarına göre sayfalar var. E stunu ile yeni sayfayı aşağıdaki kod ile oluşturuyorum. Aynı konularldarki kitapların yazar sayfalarına gidiyor ve oradan veriyi, yeni oluşturduğu konu sayfasına aktarıyor. Fakat yazar sayfasındaki bütün verileri aktarıyor. bunu yapmasın yalnızca konu sayfasının ismini baz alarak yalnızca bu konudaki satırları aktarsın.
Umarım anlatabilmişimdir. Bunu nasıl yaparım bilemedim
Option Explicit
Sub Deneme1()
Dim i, j, xr, sira As Long, sat1 As Long, Tok As String, Tik As String, s1 As Worksheet, T1 As Worksheet
Set s1 = Sheets("Bibliography")
Application.ScreenUpdating = False
For i = 3 To s1.[E65536].End(3).Row
Tok = s1.Cells(i, "E")
Tik = s1.Cells(i, "C") 'c sütünunda yazar isimleri sayfalları'
Set T1 = Sheets(Tik) 'Yazar sayfaları'
sat1 = T1.Cells(Rows.Count, "B").End(3).Row 'yazar sayfalarının en son yazılı yere kadar'
If Not Sayfakontrol(Tok) Then
Sheets("LİSTE").Select
Sheets("LİSTE").Copy after:=Worksheets(Worksheets.Count)
Sheets("LİSTE (2)").Select
Sheets("LİSTE (2)").Name = Tok
End If
sira = Sheets(Tok).Cells(Rows.Count, "B").End(3).Row + 1
If Application.WorksheetFunction.CountIf(Sheets(Tok).Range("f2:f65000"), s1.Range("f" & i)) > 0 Then
GoTo atla
Else
T1.Range("A2:N" & sat1).Copy Sheets(Tok).Cells(sira, "A")
Sheets(Tok).Range("A:n").EntireColumn.AutoFit
End If
atla:
Next i
Set s1 = Nothing
Application.ScreenUpdating = True
End Sub
C ve E stunlarına göre sayfalar var. E stunu ile yeni sayfayı aşağıdaki kod ile oluşturuyorum. Aynı konularldarki kitapların yazar sayfalarına gidiyor ve oradan veriyi, yeni oluşturduğu konu sayfasına aktarıyor. Fakat yazar sayfasındaki bütün verileri aktarıyor. bunu yapmasın yalnızca konu sayfasının ismini baz alarak yalnızca bu konudaki satırları aktarsın.
Umarım anlatabilmişimdir. Bunu nasıl yaparım bilemedim
Option Explicit
Sub Deneme1()
Dim i, j, xr, sira As Long, sat1 As Long, Tok As String, Tik As String, s1 As Worksheet, T1 As Worksheet
Set s1 = Sheets("Bibliography")
Application.ScreenUpdating = False
For i = 3 To s1.[E65536].End(3).Row
Tok = s1.Cells(i, "E")
Tik = s1.Cells(i, "C") 'c sütünunda yazar isimleri sayfalları'
Set T1 = Sheets(Tik) 'Yazar sayfaları'
sat1 = T1.Cells(Rows.Count, "B").End(3).Row 'yazar sayfalarının en son yazılı yere kadar'
If Not Sayfakontrol(Tok) Then
Sheets("LİSTE").Select
Sheets("LİSTE").Copy after:=Worksheets(Worksheets.Count)
Sheets("LİSTE (2)").Select
Sheets("LİSTE (2)").Name = Tok
End If
sira = Sheets(Tok).Cells(Rows.Count, "B").End(3).Row + 1
If Application.WorksheetFunction.CountIf(Sheets(Tok).Range("f2:f65000"), s1.Range("f" & i)) > 0 Then
GoTo atla
Else
T1.Range("A2:N" & sat1).Copy Sheets(Tok).Cells(sira, "A")
Sheets(Tok).Range("A:n").EntireColumn.AutoFit
End If
atla:
Next i
Set s1 = Nothing
Application.ScreenUpdating = True
End Sub