Girilen Veriyi Kendi Sayfasında saklama

[tkisa]

Öncelikle herkese merhabalar... Benim sorunum basit mi zormu bende bilmiyorum. Forumdaki bir kaç uzman arkadaşın uyguladığı birşeyleri denedim ama maalesef sonuca ulaşamadım. Eğer bir arkadaş ilgilenipte bana bir yol veya bir kod orneği gösterirse bu konuda cok memnun ve müteşekkir olacağım.. Benim problemim Backupların numaralarını tuttugumuz bir dosyamız var bu uzayıp gidiyor..Benim amacım ise "C1" sutununa girilen backup kayıt numaralarını hem "Backupdosyası" sayfasında olması hemde kendi sayfalarına aktarıp bu veriyi tutabilmek. İlginize şimdiden teşekkür ederim.

 

[Ömer]

Merhaba,

Kodları module kopyalayın. Eğer ikinci aktarımda eski veriler silinmeyecekse yeşil ile renklendirdiğim kodları silersiniz.

Option Explicit
 
Sub SayfaAktar()
Dim i, j As Long, Sayfa As String, S1 As Worksheet
Set S1 = Sheets("Backup Dosyası")
Application.ScreenUpdating = False
[COLOR=green]For j = 2 To Worksheets.Count[/COLOR]
[COLOR=green] Sheets(j).Cells.Delete Shift:=xlUp[/COLOR]
[COLOR=green]Next j[/COLOR]
For i = 2 To S1.[C65536].End(3).Row
    Sayfa = Cells(i, "C")
    If Not SayfaVarMi(Sayfa) Then
        Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = Sayfa
        S1.Select
        S1.Range("A1:D1").Copy Sheets(Sayfa).Range("A1")
    End If
S1.Range("A1:D1").Copy Sheets(Sayfa).Range("A1")
S1.Range("A" & i & ":D" & i).Copy Sheets(Sayfa).Range("A" & _
Sheets(Sayfa).[A65536].End(3).Row + 1)
Sheets(Sayfa).Range("A:D").EntireColumn.AutoFit
Next i
Set S1 = Nothing
Application.ScreenUpdating = True
End Sub
 
Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function

.

 

[tkisa]

Omer Bey;

İlginize Cok teşekkür ederim ..yanlız ufak bir değişiklik yapabilirseniz cok mutesekkir kalırım.. Backup Kayıt numarası 100-200 vb gibi gidiyor eger kayıt numarası 101-102-199 olsada benim belirlemiş oldugum sayfayı silmeden onu 100 lu gurubun içine ekleyebilirseniz ..gercekten cok makbule gececek uğraşlarınız için teşekkürü bir borç biliyorum..

 

[Ömer]

Bu şekilde deneyin. Eğer ikinci aktarımda eski veriler silinmeyecekse kırmızı ile renklendirdiğim kodları silersiniz.

Option Explicit
 
Sub SayfalaraDağıt()
On Error Resume Next
Dim Sayfa As String, i, son As Long, S1 As Worksheet
Set S1 = Sheets("Backup Dosyası")
Application.ScreenUpdating = False
[COLOR=red]For i = 2 To Worksheets.Count[/COLOR]
[COLOR=red]   Sheets(i).Range("B2:D65536").ClearContents[/COLOR]
[COLOR=red]Next i[/COLOR]
For i = 2 To S1.[C65536].End(3).Row
    Sayfa = Left(S1.Cells(i, "C"), 1) & "00"
    son = Sheets(Sayfa).[B65536].End(3).Row + 1
    S1.Range("B" & i & ":D" & i).Copy Sheets(Sayfa).Cells(son, "B")
Next
MsgBox "Akatarım Tamalandı.", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
Set S1 = Nothing
Application.ScreenUpdating = True
End Sub

.

 

[tkisa]

Ömer Bey ;

Valla Ne diyeyim ilginize çok teşşekürler.. tam aradığım oldu.. Ne kadar teşekkür etsem azdır.. yardım ve ilginiz için sonsuz teşekkürler..

 

[Ömer]

Rica ederim, iyi çalışmalar..