• DİKKAT

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

Makro ile nasıl yapabilirim?

J

jajiyiko

Katılım
29 Mart 2005
Mesajlar
84
Excel Vers. ve Dili
excel 2003
Merhaba!

Forumda arama yaptım ya ben bulamadım ya da yok bilemiyorum.Yardımınızı bekliyorum.

Benim excel dosyamda ik sayfa var

1 sayfamda

adi soyadi miktar
------ ------- -----------
ali falan 58
ahmet filan 24
hasan kurt 12
hüseyin yılmaz 52

gibi bilgiler ( yüzlerce kayıt) var.

Ben bu bilgileri 2. sayfaya şöyle aktarmak istiyorum.

1 sayfadaki şahsın miktarına bakacak 16 dan fazla ise kac kere fazla ise o kadar 2.sayfaya kayıt yapacak
16 dan az ise 1 kere kayıt yapacak.yani

birinci kaydı ele alalım. 2.sayfaya şu şekilde aktarmam gerekiyor.
ali falan 16
ali falan 16
ali falan 16
ali falan 10

ikinci şahıs şöyle olmalı
ahmet filan 16
ahmet filan 8

üçüncü şahıs şöyle
hasan kurt 12

bunu makro ile nasıl yapabilirim.şimdiden teşekkürler
 

Ekli dosyalar

Merhaba kodlar altta modüle kopyalayıp bir butona atayın,iyi çalışmalar.
Kod: 
Sub fdl()
For i = 3 To Sheets("sayfa1").Range("b65000").End(xlUp).Row
c = 0
If Sheets("sayfa1").Cells(i, 4).Value > 16 Then
For k = 16 To Sheets("sayfa1").Cells(i, 4).Value Step 16
c = c + 16
son = Sheets("sayfa2").Range("b65000").End(xlUp).Row + 1
Sheets("sayfa2").Cells(son, 2).Value = Sheets("sayfa1").Cells(i, 2).Value
Sheets("sayfa2").Cells(son, 3).Value = Sheets("sayfa1").Cells(i, 3).Value
Sheets("sayfa2").Cells(son, 4).Value = 16
Next
If c > 0 Then
d = Sheets("sayfa1").Cells(i, 4).Value - c
son = Sheets("sayfa2").Range("b65000").End(xlUp).Row + 1
Sheets("sayfa2").Cells(son, 2).Value = Sheets("sayfa1").Cells(i, 2).Value
Sheets("sayfa2").Cells(son, 3).Value = Sheets("sayfa1").Cells(i, 3).Value
Sheets("sayfa2").Cells(son, 4).Value = d
End If

Else
son = Sheets("sayfa2").Range("b65000").End(xlUp).Row + 1
For g = 2 To 4
Sheets("sayfa2").Cells(son, g).Value = Sheets("sayfa1").Cells(i, g).Value
Next
End If
Next
End Sub
 

Ekli dosyalar

Son düzenleme:
Merhaba,
Syn. fedeal cevaplamış; ama ben de yapmıştım, alternatif olsun.
Kod: 
Sub Aktar()
Set s2 = Sheets("Sayfa2")
Sat = 3
For x = 3 To [b65536].End(3).Row
    sayi = Cells(x, "d")
Tekrar:
If sayi > 16 Then
        s2.Cells(Sat, "b") = Cells(x, "b")
        s2.Cells(Sat, "c") = Cells(x, "c")
        s2.Cells(Sat, "d") = 16
        Sat = Sat + 1
        sayi = sayi - 16
     GoTo Tekrar
End If
If sayi < 16 And sayi > 0 Then
        s2.Cells(Sat, "b") = Cells(x, "b")
        s2.Cells(Sat, "c") = Cells(x, "c")
        s2.Cells(Sat, "d") = sayi
        Sat = Sat + 1
End If
Next
End Sub
 

Ekli dosyalar

Teşekkür ederim sorunum sayenizde çözüldü.

Sayın fedeal ve leumruk her ikinize de sonsuz teşekkür ederim.

Sorunumu çözdünüz.

Sizlere başarılar diliyorum.
 
SADECE AKTARMA MAKROSUNU YAZI VEREBİLİRMİSİNİZ
yani sayfa bideki b3 sayfa2 deki c1 gibisadece sayfa birde olanı sayfa 2 de istediğim yere aktarsam
 
istediginiz bumu;
Sheets("sayfa2").Cells(1, "c").Value = Sheets("sayfa1").Cells(3,"b").Value
 
evet emrah bey bir şöyle bir aktarma yapacak olsak örnek sayfa1 deki c3:d10 arasını sayfa2 deki c1:c7 arasına aktarmak istesek
az önceki verdiğiniz kod istediğimi yapıyor ancak tek tek aktaracak olsak işe yaradı birde belirli bir aralıkları belirli bir aralığa satır ve sütün aralıkları aynı bir yere aktaracak olsak kısa kodu nasıl olmalı
 
c3:d10 arasını sayfa2 deki c1:c7 d10 degilde c3:c10 ise
for i=1 to 7
Sheets("sayfa2").Cells(i, "c").Value = Sheets("sayfa1").Cells( i+2 ,"c").Value
next
 
emrah bey mesela 12 sayfamız var 12 sininde aralıkları aynı yani diyelimki c3:f100 arasını sayfa2 deki c1:c97 arasına başlayarak önce sayfa birdekini sonra sayfa3 dekini gibi bu nasıl olur
 
Sayfa1(verilerin oldugu) hariç tüm sayfalara aktarım yapar.bunda dikkat edilecek husus aktarım yapmak istmediginiz sayfa varsa sayfa1 hariç hepsine atacaktır.

Kod: 
Sub fd()
    Dim sayfa As Worksheet
    Dim i As Integer
    For Each sayfa In Worksheets
If sayfa.Name = "Sayfa1" Then GoTo atla
For i = 1 To 97
sayfa.Cells(i, "c").Value = Sheets("sayfa1").Cells(i + 2, "c").Value
Next
atla:
Next
End Sub
 
emrah bey yapbak istediğim sayfa1 a1:e100 bu şekilde 12 sayfa var 13. sayfa ilk başa sayfa1 rin a1:e100 arasını sonra sayfa2 nin a101:e200 arasına gibi aşağıya doğru 12 sayfayı aktarmak istiyotum
 
Söylede olabilir.(eğer sayfa2,sayfa3,sayfa4 diye gidiyorsa)
sayfa2 ... sayfa12 arasına verileri aktarır.
Kod: 
Sub fdl()
For syf = 2 To 12
Set sayfa = Sheets("Sayfa" & syf)
For i = 1 To 97
sayfa.Cells(i, "c").Value = Sheets("sayfa1").Cells(i + 2, "c").Value
Next
Next
End Sub
 
o zaman iş değişir sayfa13'e sayfa1....sayfa12 a1:e100 arasını altalta aktarır.

Kod: 
Sub fdl()
s = 1
For syf = 1 To 12
Set sayfa = Sheets("Sayfa" & syf)
For i = 1 To 100
Sheets("sayfa13").Cells(s, "a").Value = sayfa.Cells(i, "a").Value
Sheets("sayfa13").Cells(s, "b").Value = sayfa.Cells(i, "b").Value
Sheets("sayfa13").Cells(s, "c").Value = sayfa.Cells(i, "c").Value
Sheets("sayfa13").Cells(s, "d").Value = sayfa.Cells(i, "d").Value
Sheets("sayfa13").Cells(s, "e").Value = sayfa.Cells(i, "e").Value
s = s + 1
Next
Next
End Sub
 
Dosya ekte inceleyin,

Kod: 
Sub fdl()
arr = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
S = 1
For syf = 0 To 11
Set sayfa = Sheets(arr(syf) & " GELİR")
For i = 1 To 30
Sheets("YILLIK GELİR").Cells(S, "a").Value = sayfa.Cells(i, "a").Value
Sheets("YILLIK GELİR").Cells(S, "b").Value = sayfa.Cells(i, "b").Value
Sheets("YILLIK GELİR").Cells(S, "c").Value = sayfa.Cells(i, "c").Value
Sheets("YILLIK GELİR").Cells(S, "d").Value = sayfa.Cells(i, "d").Value
Sheets("YILLIK GELİR").Cells(S, "e").Value = sayfa.Cells(i, "e").Value
S = S + 1
Next
Next
End Sub

not: array olayın sayın Halit3 ten ögrendim kendisine teşekkürler.
 

Ekli dosyalar

Emrah bey çok teşekkür ederim bir çok aktarma kodu oluşturuverdiniz
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst