Sayfaya veri aktarımı hakkında

[jetis]

bu sayfadaki makroları forumlardan almıştım.Ama takıldığım noktalar oldu yardımcı olusanız sevinirim.Şimdiden Teşekkür ederim.

 

[jetis]

Pardon dosyayı koymayı unutmuşum

 

[Orion1]

Dosyanız ekte.

 

[jetis]

hocam teşekkür ederim sütün genişlikleri olmuş
alt toplamlar için yapabileceğimiz bir çözüm yok mu?

 

[Ayhan Ercan]

Merhaba sn jetis

Biraz değişik oldu ama isterseniz birde ekdeki dosyayı deneyiniz....

Sub aktar()
Dim hcr As Range, syf As Worksheet, i As Integer, son As Long
Application.ScreenUpdating = False
For Each hcr In Sheets("VERİ").Range("b2:b" & Sheets("VERİ").[b65536].End(3).Row)
    For Each syf In Worksheets
        If syf.Name = hcr.Value Then
            syf.Select
            syf.Range("a" & syf.[a65536].End(3).Row + 1).Activate
            For i = 0 To 6
                ActiveCell.Offset(0, i) = hcr.Offset(0, i - 1).Value
            Next
        End If
    Next
Next
Sheets(1).Select
        For i = 2 To Sheets.Count
            With Sheets(i)
                son = .[a65536].End(3).Row + 3
                .Range("D" & son) = "GENEL TOPLAM"
                .Range("e" & son).Formula = "=sum(" & ("E2:E") & son - 2 & ")"
                .Range("f" & son).Formula = "=sum(" & ("F2:F") & son - 2 & ")"
                .Range("g" & son).Formula = "=sum(" & ("G2:G") & son - 2 & ")"
            End With
        Next
Application.ScreenUpdating = True
MsgBox "Aktarma işlemi Tamamlanmıştır..!!"
End Sub

 

[mami68]

Merhabalar.
Sayın Ayhan Ercan elinize sağlık güzel olmuş,birde buna yeni gelen araç için yeni sayfa açılsın olurmu.Çünkü sadece listede olanların dağıtımını yapıyor yeni plaka eklediğin zaman yeni sayfa açmıyor.İyi çalışmalar.

 

[Ayhan Ercan]

Merhabalar.
...yeni gelen araç için yeni sayfa açılsın olurmu...
..........yeni plaka eklediğin zaman yeni sayfa açmıyor...

Aşağıdaki kodu "VERİ" sayfasının kod penceresine yazıp deneyiniz.....

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sf As Worksheet
Application.ScreenUpdating = False
If Intersect(Target, Range("b:b")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
For Each sf In Worksheets
    If sf.Name = Target.Value Then GoTo devam
Next
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Target.Value
Sheets(1).Range("a1:g1").Copy
Sheets(Sheets.Count).[a1].PasteSpecial Paste:=xlPasteColumnWidths
Sheets(Sheets.Count).Paste
Application.CutCopyMode = False
    With Sheets(Sheets.Count).Columns("A:G").Font
        .Name = "Arial"
        .Bold = True
        .Size = 10
    End With
    With Sheets(Sheets.Count).Range("A1:G1").Font
        .Name = "Arial"
        .Size = 20
    End With
    Sheets(Sheets.Count).Columns("E:G").NumberFormat = "#,##0.00"
Application.ScreenUpdating = True
Sheets("VERİ").Select
devam:
Exit Sub
End Sub

 

[mami68]

Sayın Ayhan Ercan Elinize sağlık mükkemel olmuş.

 

[jetis]

ayhan bey ilginiz için teşekkür ederim ama yazdığınız gibi yaptım ama aynı verileri aktarıyor yeni plakaları sayfa ya aktarmıyor.birdaha bakarsanız memnun olurum.

 

[jetis]

pardon hocam işlem tamam da veri sayfasındaki leri tekrar tekrar aktarıyor sayfalara nerde yanlış yapıyorum acaba ?