• DİKKAT

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

Makro ile şartlı aktarma

S

savasizgeneral

Katılım
14 Şubat 2008
Mesajlar
38
Excel Vers. ve Dili
office 2019 türkçe
Merhaba ben bir sayfadan diğer sayfaya veri dağıtmak istiyorum, fakat dağıtacağım verilerin belli şartlara göre gelmesini istiyorum.
Dağıtılacak sayı b sütünunda dağıtım şekli data sayfasından alınacak
Data sayfasındaki a sütunundaki sayılar baz alınıp bulunan sayıya göre b ile j sutunu arasındaki sayılar sayfa 1 deki d ile ah sutununa dağıtılacak
Sayfa 1 deki d ile ah sütunu arasında dağılacak olan sayılar sadece sütunlardaki 'N' yazan yerlere yazılacak
Dağıtımda öncelik olarak 'N' ler arasında en az 2 boşluk olacak şekilde olacak yani 2 'N' ye yanyana yazmayacak , fakat yazdırılacak alan yetmediği durumlarda aradaki boşluk kademeli olarak 1 boşluk ve boşluk yok olarak düşebilir.


Teşekkürler.
 

Ekli dosyalar

Son düzenleme:
Arkadaşlar sorunumu parça parça çözmeye çalışacam aşağıdaki makro ile veriyi aktarabiliyorum, benim istediğim aktarım yapılan hücreler benim dosyamda dolu olacak ben bir kriter belirleyip belirlediğim kritere göre aktarım yapmasını istiyorum, yani c sutunda bir veri arayıp o verinin üzerine yazacak. aynı işlemleri diğer sütünlarda da yapacak.


Sub arabul59()
Dim sh As Worksheet, sonsat1 As Long, sonsat2 As Long
Dim i As Long, k As Range
Set sh = Sheets("Sayfa1")
sonsat1 = sh.Cells(Rows.Count, "A").End(xlUp).Row
sonsat2 = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sonsat2
Set k = sh.Range("A2:A" & sonsat1).Find(Cells(i, "A").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
Cells(i, "c").Value = k.Offset(0, 10).Value
Cells(i, "d").Value = k.Offset(0, 9).Value
Cells(i, "e").Value = k.Offset(0, 8).Value
Cells(i, "f").Value = k.Offset(0, 7).Value
Cells(i, "g").Value = k.Offset(0, 6).Value
Cells(i, "h").Value = k.Offset(0, 5).Value
Cells(i, "ı").Value = k.Offset(0, 4).Value
Cells(i, "j").Value = k.Offset(0, 3).Value
Cells(i, "k").Value = k.Offset(0, 2).Value
Cells(i, "l").Value = k.Offset(0, 1).Value
End If
Next i
MsgBox "İşlem tamamlanmıştır."
End Sub
 

Ekli dosyalar

Bu makro ile yukarıdaki makro birleştirilebilir mi?

With Worksheets(1).Range("a1:a500")
Set c = .Find(2, lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
 
Ömer bey bi sorum daha olacak şimdi bu yaptığınız makroyu ben kendi çalışma kitabıma uyarlamaya çalıştım fakat beceremedim, dağıtılacak sayı kısmını nasıl değiştirebilirim b sütunu yerine başka sütunu nasıl gösterebilirim? Makro değişiklik yapılabilecek şekilde düzenlenebilir mi?
Teşekkürler.

Sub DAGITIM_BRN()
Set s1 = Sheets("Sayfa1"): Set sd = Sheets("data")
Set wf = Application.WorksheetFunction
For sat = 3 To s1.Cells(Rows.Count, 2).End(3).Row
dsat = s1.Cells(sat, 2) + 1
dadet = sd.Cells(s1.Cells(sat, 2) + 1, 256).End(1).Column - 1
nadet = wf.CountIf(s1.Range("D" & sat & ":AH" & sat), "N")
sekme = Int(nadet / dadet)
ilk = wf.Match("N", s1.Range("D" & sat & ":AH" & sat), 0) + 3: sayı = 0: dsut = 2
s1.Cells(sat, ilk) = sd.Cells(dsat, dsut)
For n = ilk + 1 To 34
If s1.Cells(sat, n) = "N" Then
sayı = sayı + 1
If sayı >= sekme Then
If dsut >= dadet + 1 Then GoTo 20
dsut = dsut + 1: s1.Cells(sat, n) = sd.Cells(dsat, dsut): sayı = 0
End If: End If: Next
20: Next
End Sub

Sub BAŞA_DÖN()
For sat = 3 To Cells(Rows.Count, 2).End(3).Row
For sut = 4 To 34
Cells(sat, sut) = Cells(sat + 15, sut)
Next
Next
End Sub
 
savasizgeneral' Alıntı:
Ömer bey bi sorum daha olacak şimdi bu yaptığınız makroyu ben kendi çalışma kitabıma uyarlamaya çalıştım fakat beceremedim, dağıtılacak sayı kısmını nasıl değiştirebilirim b sütunu yerine başka sütunu nasıl gösterebilirim? Makro değişiklik yapılabilecek şekilde düzenlenebilir mi?
Teşekkürler.
Genişletmek için tıkla ...
Merhaba.

Kırmızı işaretledim.
.
Kod: 
For sat = 3 To s1.Cells(Rows.Count, [COLOR="red"][B]"B"[/B][/COLOR]).End(3).Row
dsat = s1.Cells(sat, [COLOR="red"][B]"B"[/B][/COLOR]) + 1
dadet = sd.Cells([B][COLOR="Red"]dsat[/COLOR][/B], 256).End(1).Column - 1
 
Kırmız ile belirtiğim yerde hata veriyor.


Sub DAGITIM_BRN()
Set s1 = Sheets("MESAİ VE İZİNLER"): Set sd = Sheets("SAAT")
Set wf = Application.WorksheetFunction
For sat = 3 To s1.Cells(Rows.Count, "C").End(3).Row
dsat = s1.Cells(sat, "C") + 1
dadet = sd.Cells(s1.Cells(dsat, 2) + 1, 256).End(1).Column - 1
nadet = wf.CountIf(s1.Range("D" & sat & ":AH" & sat), "x")
sekme = Int(nadet / dadet)
ilk = wf.Match("x", s1.Range("D" & sat & ":AH" & sat), 0) + 3: sayı = 0: dsut = 2
s1.Cells(sat, ilk) = sd.Cells(dsat, dsut)
For n = ilk + 1 To 34
If s1.Cells(sat, n) = "x" Then
sayı = sayı + 1
If sayı >= sekme Then
If dsut >= dadet + 1 Then GoTo 20
dsut = dsut + 1: s1.Cells(sat, n) = sd.Cells(dsat, dsut): sayı = 0
End If: End If: Next
20: Next
End Sub
 
Gerçek belgeyle aynı yapıda örnek belge üzerinden destek istenilmeyince böyle durumlar oluyor.
Örnek belgenizi, gerçek belgenizle aynı yapıda olacak şekilde ekleyin bakayım.
(sayfa adı/ veri başlangıç-bitiş satırı aynı olacak şekilde, data sayfası için de aynı şey geçerli)
.
 
Aşağıdaki gibi olacak.
.
Kod: 
[B]Sub DAGITIM_BRN()[/B]
Set s1 = Sheets("MESAİ VE İZİNLER"): Set sd = Sheets("SAAT")
Set wf = Application.WorksheetFunction
For sat = [B][COLOR="red"]6[/COLOR][/B] To s1.Cells(Rows.Count, "C").End(3).Row
dsat = s1.Cells(sat, "C") + 1
dadet = sd.Cells([B][COLOR="red"]dsat[/COLOR][/B], 256).End(1).Column - 1
nadet = wf.CountIf(s1.Range("D" & sat & ":AH" & sat), [B][COLOR="red"]"N"[/COLOR][/B])
sekme = Int(nadet / dadet)
ilk = wf.Match([B][COLOR="red"]"N"[/COLOR][/B], s1.Range("D" & sat & ":AH" & sat), 0) + 3: sayı = 0: dsut = 2
s1.Cells(sat, ilk) = sd.Cells(dsat, dsut)
For n = ilk + 1 To 34
If s1.Cells(sat, n) = [B][COLOR="red"]"N"[/COLOR][/B] Then
sayı = sayı + 1
If sayı >= sekme Then
If dsut >= dadet + 1 Then GoTo 20
dsut = dsut + 1: s1.Cells(sat, n) = sd.Cells(dsat, dsut): sayı = 0
End If: End If: Next
20: Next
[B]End Sub[/B]
 
Ömer bey sorunu çözdüm ilgilendiğiniz için teşekkür ederim.

Sub DAGITIM_BRN()
Set s1 = Sheets("MESAİ VE İZİNLER"): Set sd = Sheets("SAAT")
Set wf = Application.WorksheetFunction
For sat = 6 To s1.Cells(Rows.Count, "c").End(3).Row
dsat = s1.Cells(sat, "c") + 1
dadet = sd.Cells(s1.Cells(sat, "c") + 1, 256).End(1).Column - 1
nadet = wf.CountIf(s1.Range("D" & sat & ":AH" & sat), "N")
sekme = Int(nadet / dadet)
ilk = wf.Match("N", s1.Range("D" & sat & ":AH" & sat), 0) + 3: sayı = 0: dsut = 2
s1.Cells(sat, ilk) = sd.Cells(dsat, dsut)
For n = ilk + 1 To 34
If s1.Cells(sat, n) = "N" Then
sayı = sayı + 1
If sayı >= sekme Then
If dsut >= dadet + 1 Then GoTo 20
dsut = dsut + 1: s1.Cells(sat, n) = sd.Cells(dsat, dsut): sayı = 0
End If: End If: Next
20: Next
End Sub
 
Ömer bey cevap yazmışsınız görmedim kusura bakmayın bende çözümü bulunca uğraşmayın diye yazmış bulundum. Ellerinize sağlık.
 
Merhaba aşağıdaki koda ekleme yapabilirmiyiz ?
İstediğim c sutununda boş hücre varsa onları atlasın sadece dolu hücrelerde işlem yapsın istiyorum bu kod boş hücre olunca hata veriyor.

Sub DAGITIM_BRN()
Set s1 = Sheets("MESAİ VE İZİNLER"): Set sd = Sheets("SAAT")
Set wf = Application.WorksheetFunction
For sat = 6 To s1.Cells(Rows.Count, "C").End(3).Row
dsat = s1.Cells(sat, "C") + 1
dadet = sd.Cells(dsat, 256).End(1).Column - 1
nadet = wf.CountIf(s1.Range("D" & sat & ":AH" & sat), "N")
sekme = Int(nadet / dadet)
ilk = wf.Match("N", s1.Range("D" & sat & ":AH" & sat), 0) + 3: sayı = 0: dsut = 2
s1.Cells(sat, ilk) = sd.Cells(dsat, dsut)
For n = ilk + 1 To 34
If s1.Cells(sat, n) = "N" Then
sayı = sayı + 1
If sayı >= sekme Then
If dsut >= dadet + 1 Then GoTo 20
dsut = dsut + 1: s1.Cells(sat, n) = sd.Cells(dsat, dsut): sayı = 0
End If: End If: Next
20: Next
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst