• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

aylara göre veri aktarma

  • Konbuyu başlatan Konbuyu başlatan İhsan Tank
  • Başlangıç tarihi Başlangıç tarihi
İ

İhsan Tank

Misafir
s.a.
arkadaşlar benim bir sorum var
Giriş Sayfasında B1 hücresinden seçtiğim Aylara göre sekmelere ayrı ayrı kayıt etmesi ve toplamlarını giriş sekmesinde ayların karşısına toplaması.
örneğin
Ocak
100 18 118
200 36 236 gibi
her kayıtta ilk boş satıra kaydetmesi.
örnek dosya ekte
 

Ekli dosyalar

dener misiniz?

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
   
Dim syf1 As Worksheet, syf2 As Worksheet, syf3 As Worksheet, syf4 As Worksheet
Dim sat As Long

Set syf1 = Worksheets("Ocak - Mart")
Set syf2 = Worksheets("Nisan - Haziran")
Set syf3 = Worksheets("Temmuz - Eylül")
Set syf4 = Worksheets("Ekim - Aralık")

If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub

If Target.Address = "$B$1" Then
    On Error Resume Next
        Application.EnableEvents = False
        Range("B2:B4").Copy
        Select Case Target
             Case Is = "Ocak"
                syf1.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
             Case Is = "Şubat"
                syf1.Range("D65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
             Case Is = "Mart"
                syf1.Range("G65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
             Case Is = "Nisan"
                syf2.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
             Case Is = "Mayıs"
                syf2.Range("D65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
             Case Is = "Haziran"
                syf2.Range("G65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
             Case Is = "Temmuz"
                syf3.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
             Case Is = "Ağustos"
                syf3.Range("D65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
             Case Is = "Eylül"
                syf3.Range("G65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
             Case Is = "Ekim"
                syf4.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
             Case Is = "Kasım"
                syf4.Range("D65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
             Case Is = "Aralık"
                syf4.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
            Case Else
        End Select
        
        Application.CutCopyMode = False
        Application.EnableEvents = True
        
        sat = Application.Match(Target, Range("H1:H12"), 0)
        Range("I" & sat) = Range("B4")
    
    On Error GoTo 0
End If

End Sub
 
Son düzenleme:
İhsan Tank' Alıntı:
s.a.
arkadaşlar benim bir sorum var
Giriş Sayfasında B1 hücresinden seçtiğim Aylara göre sekmelere ayrı ayrı kayıt etmesi ve toplamlarını giriş sekmesinde ayların karşısına toplaması.
örneğin
Ocak
100 18 118
200 36 236 gibi
her kayıtta ilk boş satıra kaydetmesi.
örnek dosya ekte
Genişletmek için tıkla ...

Hocam bu bir testmi?
 
alternatif kod

Sub AKTAR()
Set Sh2 = Sheets("Giriş")
aranan = Sh2.Cells(1, "b").Value
For J = 1 To ActiveWorkbook.Sheets.Count
If Sheets(J).Name <> "Giriş" Then
Set Sh1 = Sheets(Sheets(J).Name)
With Sh1.Range("A1:I1")
Set d = .Find(What:=aranan, After:=.Cells(.Cells.Count), LookIn:=xlValues, lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not d Is Nothing Then
FirstAddress = d.Address
Do
sat = d.Column
son = .Cells(65000, sat).End(3).Row + 1
Sh1.Cells(son, sat).Value = Sh2.Cells(2, "b").Value
Sh1.Cells(son, sat + 1).Value = Sh2.Cells(3, "b").Value
Sh1.Cells(son, sat + 2).Value = Sh2.Cells(4, "b").Value
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With
Set Sh = Nothing
End If
Next J
MsgBox "işlem tamam"
End Sub
Genişletmek için tıkla ...
 
pardon.
benim kod tek kayıt varsayımı ile yapılmıştı. hatalı olmuş. en azından hatalı bölümü 2 no.lu mesajda düzeltiyorum.




2. bir yanlış anlmayı da sonra düzeltirim. ilgili ayın kdv dahil toplamı giriş sayfasına aktarılacak.
(diğer husu çözülür...)

hay Allah elimizi yüzümüze bulaştırdık.
 
Son düzenleme:
Bunu denermisiniz.
kodu giriş sayfasına koyacaksınız.
kod hücrede işlem yaptıktan sonra çalışıyor.


Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B1:B2")) Is Nothing Then Exit Sub
AKTAR
End Sub
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst