renge göre aktar

[ckkaraca]

Ekli dosyada da açıkladığım üzere sarı renkle dolgu yaptığım satır ve sağındaki satırların diğer sayfaya aktırılması konusunda yardım ederseniz çok sevinirim

 

[halit3]

Ekli dosyada da açıkladığım üzere sarı renkle dolgu yaptığım satır ve sağındaki satırların diğer sayfaya aktırılması konusunda yardım ederseniz çok sevinirim

kod

Sub aktar()
sat = WorksheetFunction.CountA(Worksheets("kargo").Range("A2:A27")) + 2
For i = 2 To Worksheets("satış").[a65536].End(3).Row
If Sheets("satış").Cells(i, 1).Interior.ColorIndex = 6 Then
For j = 1 To 49
Sheets("kargo").Cells(sat, j).Value = Sheets("satış").Cells(i, j).Value
Next
sat = sat + 1
End If
Next i
MsgBox " işlem Tamanlanmıştır..."
End Sub

 

[Orion1]

Dosyanız ektedir.

Sub renge_gore_aktar()
Dim hcr As Range, sh As Worksheet, k As Range, j As Integer
Dim sat As Long, adr As String
sat = Cells(65536, "A").End(xlUp).Row
Set sh = Sheets("kargo")
sh.Range("C2:AW26").ClearContents
Application.ScreenUpdating = False
For Each hcr In Range("A2:A" & sat)
    If hcr.Interior.Color = vbYellow Then
        Set k = sh.Range("B2:B26").Find(hcr.Offset(0, 1).Value, , xlValues, xlWhole)
        adr = k.Address
        Do
            If hcr.Value = k.Offset(0, -1).Value Then
                sh.Range("C" & k.Row & ":AW" & k.Row).Value = _
                Range("C" & hcr.Row & ":AW" & hcr.Row).Value
            End If
            Set k = sh.Range("B2:B26").FindNext
        Loop While Not k Is Nothing And k.Address <> adr
    End If
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[ckkaraca]

Halit hocam çok teşekkür ederim yardımınız için ufak bir detay için daha yardım isteyeceğim.Aktardığım kargo sayfası değişken olduğu için aktar butonu ile birlikte kargo sayfasında 2 ile 26. satırları yani bir önceki aktarımı temizlemesi gerekiyor

 

[Orion1]

Ben konuyu yanlışmı anladım.
3 numaralı mesajdaki dosyaı çalıştırııp denermisiniz.Hem tarih denetliyor hemde isim denetliyor.Hemde renk denetliyor.

 

[ckkaraca]

Evren hocam teşekkür ederim ancak makro hata veriyor adr = k.Address satırında

 

[ckkaraca]

Hocam tam olarak ben anlatamadım sanırım.Satış sayfasında sarı renkle dolgu yaptığım tarih satırına göre (örneğin 23.satırda 26/01/2010 tarihini) sağa doğru aldığı tüm değerleri kargo sayfasına aktarmasını istiyordum.Ama birden fazla sarı dolgu yaptığım için bunu sırası ile kargo sayfasında 2.satırdan aşağı doğru aktarması ve her ctrl+n kullandığımda kargo sayfasında 2.satır ile 26.satır arasını temizlemesi gerekiyor.Kullanım amacımı izah edeyim çalıştığım firma bir gün içinde farklı kişilere (a,b,c,...) 1,2,3,4... gibi malları sevk ediyor kargo ödemesini takip edebilmem için kargonun maliyetini her gün çıkarmam gerekiyor. Bu işlemi kolaylaştırmak için hazırlamay çalışıyorum

 

[ckkaraca]

evren hocam yukarda anlattığım üzere daha farklı bir çalışma önerirseniz onada sevinirim

 

[halit3]

Halit hocam çok teşekkür ederim yardımınız için ufak bir detay için daha yardım isteyeceğim.Aktardığım kargo sayfası değişken olduğu için aktar butonu ile birlikte kargo sayfasında 2 ile 26. satırları yani bir önceki aktarımı temizlemesi gerekiyor

bunu denermisiniz.

Sub aktar()
Sheets("kargo").Range("A2:AW26").ClearContents
sat = WorksheetFunction.CountA(Worksheets("kargo").Range("A2:A27")) + 2
For i = 2 To Worksheets("satış").[a65536].End(3).Row
If Sheets("satış").Cells(i, 1).Interior.ColorIndex = 6 Then
For j = 1 To 49
Sheets("kargo").Cells(sat, j).Value = Sheets("satış").Cells(i, j).Value
Next
sat = sat + 1
End If
Next i
MsgBox " işlem Tamanlanmıştır..."
End Sub

 

[Orion1]

evren hocam yukarda anlattığım üzere daha farklı bir çalışma önerirseniz onada sevinirim

Dosyayı güncelledim.3 numaralı mesajdan inidrebilirsiniz.