verileri alt alta kaydetmek

[kontto]

Arkadaşlar dosyayı ekte gönderdim. Bu konuda yardımcı olursanız sevinirim. Şimdiden teşekkür ederim. Çok ihtiyacım var.

 

[mancubus]

aşağıdaki kodu butona atayabilirsiniz.
idare eder zannediyorum.

Sub Macro1()

Dim il As String
Dim sc, sd As Worksheet

Set sc = ActiveWorkbook.Sheets("Sayfa1")
Set sd = ActiveWorkbook.Sheets("Sayfa2")

il = sc.Range("$B$4").Value
rw = Application.Match(Trim(il), sd.Columns("A"), 0)

sc.Range("B4:F4").Copy
sd.Select
Cells(rw, 1).End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False

End Sub

 

[kontto]

Teşekkür ederim ama 400 diye error hatası verdi.

 

[mancubus]

Teşekkür ederim ama 400 diye error hatası verdi.

sizin dosyanız üzerinden excel 2007'de çalıştırdığımda problemsiz çalışıyor.

hangi satırda hata veriyor. (satır sarı renk oluyor.)

 

[mancubus]

tamam hatanın nedenini anladım.

uygun bir zamanda yanıt vermeye çalışayım.

 

[mancubus]

merhaba.
Sayfa2'de 81 il isminin belli satır aralıklarıyla yazılı olduğu varsayımıyla cevap vermiştim. (ki, o da hatalı ve düzeltilmesi gerekecek.)

ancak Sayfa1'deki B4:F4 hücrelerinin Sayfa2'deki ilk boş satıra kopyalanmasını istiyorsanız çözüm çok basit. Sonra A sütununa (il adı) göre sıralayabilirsiniz.

 

[mancubus]

tamam hatanın nedenini anladım.

uygun bir zamanda yanıt vermeye çalışayım.

şu kod bende çalıştı. Sayfa1'deki il ismi Sayfa2'de A sütununda mutlaka en az 1 defa yazılmış olmalı.
bir vesile ile, birden fazla aynı il ismi var ise alt alta olmalı

Sub AltAltaKopya()

Dim il As String
Dim sc, sd As Worksheet

Set sc = ActiveWorkbook.Sheets("Sayfa1")
Set sd = ActiveWorkbook.Sheets("Sayfa2")

il = sc.Range("$B$4").Value
rw1 = Application.Match(Trim(il), sd.Columns("A"), 0)
rw2 = Application.CountIf(sd.Columns("A"), Trim(il))

sd.Select
With sd
tst = Application.CountA(sd.Range(Cells(rw1, 1), Cells(rw1, 5)))
End With

sc.Range("B4:F4").Copy
sd.Select

If tst = 1 Then
    Cells(rw1, 1).Select
Else
    Cells(rw1 + rw2, 1).Select
End If

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False

End Sub

 

[mancubus]

ancak Sayfa1'deki B4:F4 hücrelerinin Sayfa2'deki ilk boş satıra kopyalanmasını istiyorsanız çözüm çok basit. Sonra A sütununa (il adı) göre sıralayabilirsiniz.

bu işlem için de:

Sub AltAltaKopya2()

Dim sc, sd As Worksheet

Set sc = ActiveWorkbook.Sheets("Sayfa1")
Set sd = ActiveWorkbook.Sheets("Sayfa2")

LR = Sheets("Sayfa2").Range("A65536").End(xlUp).Row + 1

sc.Range("B4:F4").Copy
sd.Select
Cells(LR, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False

End Sub

 

[kontto]

teşekkür ederim hemen deneyeceğim.

 

[mancubus]

AltAltaKopya2() makrosunda "End Sub" ibaresinden önce gelecek şekilde aşağıdaki kodları eklerseniz her kayıt sonrasında veri tablonuzun il adına göre sıralanmasını da sağlarsınız.

ActiveWorkbook.Worksheets("Sayfa2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sayfa2").Sort.SortFields.Add Key:=Range("A2"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sayfa2").Sort
    .SetRange Range("A2:E65536")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

 

[mancubus]

pivot tablo eklenmiş ve her veri girişinde il adına göre sort ederek pivot tabloyu güncelleyen macronun yer aldığı dosyayı ekledim. xl2007.

 

[kontto]

Çooook Teşekkür ederim. İşime Yaradı. Allah razı olsun

 

[mancubus]

rica ederim.

konunun uzmanı değilim. gündelik çalışmalarda kendi kullandığım bazı kodları sizin duruma uyarladım sadece.

 

[kontto]

Çok teşekkür ederim emeğine sağlık.