• DİKKAT

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

sayfalar arasi verileri aktarma.

Y

yNsr43

Katılım
24 Mart 2017
Mesajlar
148
Excel Vers. ve Dili
ofis 2013
Kod: 
Sub degistir()
Dim sh As Worksheet, sonsat As Long
Dim k As Range
Sheets("sayfa1").Select
Set sh = Sheets("1")
Set sd = Sheets("2")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Set k = sh.Range("A1:A" & sonsat).Find(Range("A2").Value, , xlValues, xlWhole)
Set d = sd.Range("A1:A" & sonsat).Find(Range("A2").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    k.Offset(0, 2).Value = Range("B2").Value
    d.Offset(0, 2).Value = Range("c2").Value
    sh.Select
End If
End Sub

merhabalar
sayfa1 "a2" hücresindeki de yazani "1" ve "2" de aratip yanina B2 ve C2 hücresini kopyalayan bir makro yazmayi başardim.
bunu sadece a2 de yazanı değil A kolonunun hepsini "1" ve "2" sayfalara dağtmak istiyorum.

sanırım o da şu "Find(Range("A2").Value" bunun yarine ne kullanmam gerekiyor.

teşekkürler.

http://s3.dosya.tc/server14/rhrsk5/Kitap155.rar.html
 
Merhaba,

İlavaler:

-Tüm sütun için arama sağlandı.
-Aranan sayfalar dizi içine alınarak sayfa ilavesi kolaylaştı.
-Önce aranan sayfalardaki aralıklar silindi.
-Aranan veriden birden fazla olabileceği düşüncesiyle bul komutuna döngü eklendi.

Kod: 
Sub Aktar()

    Dim syf(), i As Byte, j As Long, c As Range, Adr As String
    
    syf = Array("1", "2") 'aranan sayfalar
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    
    For i = 0 To UBound(syf)
        Sheets(syf(i)).Range("B:C").ClearContents
    Next i
        
    For i = 0 To UBound(syf)
        With Sheets(syf(i))
            For j = 1 To Cells(Rows.Count, "A").End(xlUp).Row
                Set c = .[A:A].Find(Cells(j, "A"), , xlValues, xlWhole)
                If Not c Is Nothing Then
                    Adr = c.Address
                    Do
                        .Cells(c.Row, "B") = Cells(j, "B")
                        .Cells(c.Row, "C") = Cells(j, "C")
                        Set c = .[A:A].FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Adr
                End If
            Next j
        End With
    Next i

End Sub

.
 
elinize sağlık

sayfa1 deki verileri komple 1 v 2 sayfalara atiyor.

"sayfa1" B sütunundaki veriler "1" sayfasina C sütununa
"sayfa1" c sütunundaki veriler "2" sayfasina C sütununa atmasını istiyordum.

teşekkür ederim.
 
İstediğiniz bu mu?

Kod: 
Sub Aktar()

    Dim syf(), i As Byte, j As Long, c As Range, Adr As String
    
    syf = Array("1", "2") 'aranan sayfalar
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    
[COLOR="Red"]    For i = 0 To UBound(syf)
        Sheets(syf(i)).Range("B:C").ClearContents
    Next i[/COLOR]
        
    For i = 0 To UBound(syf)
        With Sheets(syf(i))
            For j = 1 To Cells(Rows.Count, "A").End(xlUp).Row
                Set c = .[A:A].Find(Cells(j, "A"), , xlValues, xlWhole)
                If Not c Is Nothing Then
                    Adr = c.Address
                    Do
                        If .Name = "1" Then
                            .Cells(c.Row, "C") = Cells(j, "B")
                        Else
                            .Cells(c.Row, "C") = Cells(j, "C")
                        End If
                        Set c = .[A:A].FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Adr
                End If
            Next j
        End With
    Next i

End Sub

.
 
evet istediğim tam olarak bu elinize sağlık ama buda da şöyle birşey oldu
"1" ve "2" sayfalarinda c kolonunda önceden var olan verileri siliyor bunu nasıl önleyebilirz.
teşekkürler.
 
Önceden yazılı veriler silinmeyecekse, #4 numaralı mesajdaki işaretlediğim kırmızı alanı silmeniz yeterli olur.

.
 
1-2 sayfaları C sütununda veri varsa yeni veriyi üzerine yazmaması mı gerekiyor. Eski veri mi kalması gerekiyor.
 
evet 1-2 sayfaları C sütununda veri varsa yeni veriyi üzerine yazmaması gerekiyor.
teşekkürler.
 
Bu şekilde deneyin.

Kod: 
Sub Aktar()

    Dim syf(), i As Byte, j As Long, c As Range, Adr As String
    
    syf = Array("1", "2") 'aranan sayfalar
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    For i = 0 To UBound(syf)
        With Sheets(syf(i))
            For j = 1 To Cells(Rows.Count, "A").End(xlUp).Row
                Set c = .[A:A].Find(Cells(j, "A"), , xlValues, xlWhole)
                If Not c Is Nothing Then
                    Adr = c.Address
                    Do
                        If .Cells(c.Row, "C") = "" Then
                            If .Name = "1" Then
                                .Cells(c.Row, "C") = Cells(j, "B")
                            Else
                                .Cells(c.Row, "C") = Cells(j, "C")
                            End If
                        End If
                        Set c = .[A:A].FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Adr
                End If
            Next j
        End With
    Next i

End Sub

.
 
Kod: 
Sub Aktar()

    Dim syf(), i As Byte, j As Long, c As Range, Adr As String
    
    syf = Array("1", "2") 'aranan sayfalar
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    For i = 0 To UBound(syf)
        With Sheets(syf(i))
            For j = 1 To Cells(Rows.Count, "A").End(xlUp).Row
                Set c = .[A:A].Find(Cells(j, "A"), , xlValues, xlWhole)
                If Not c Is Nothing Then
                    Adr = c.Address
                    Do
[COLOR="Red"]                        If .Name = "1" Then
                            .Cells(c.Row, "C") = Cells(j, "B")
                       Else
                            .Cells(c.Row, "C") = Cells(j, "C")[/COLOR]
                       
                        End If
                        Set c = .[A:A].FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Adr
                End If
            Next j
        End With
    Next i

End Sub

tekrar merhaba boş bir excel dosyasinda çaliştirdiğimda pek sıkıntı olmuyor lakin çalişma dosyamda çaliştirdiğimda "1" deki tarih kısımına da "2" ye yazmasi gerekenleri yaziyor. bunun nedeni kırmızı işaretli yer mi acaba ?
teşekkürler.
 
Şöyle deneyiniz.:cool:
Kod: 
For i = 1 To UBound(syf) +1
 
böyle deneyin.:cool:
Kod: 
For i = 1 To 2
        With Sheets(cstr(i))
 
Kod: 
Sub Aktar()

    Dim syf(), i As Byte, j As Long, c As Range, Adr As String
    
    syf = Array("tarih", "fiyat") 'aranan sayfalar
    
    Application.ScreenUpdating = False
    Sheets("ftaktar").Select
    For i = tarih To fiyat
        With Sheets(cstr(i))
            For j = 1 To Cells(Rows.Count, "A").End(xlUp).Row
                Set c = .[A:A].Find(Cells(j, "A"), , xlValues, xlWhole)
                If Not c Is Nothing Then
                    Adr = c.Address
                    Do
                        If .Cells(c.Row, "C") = "" Then
                            If .Name = "1" Then
                                .Cells(c.Row, "C") = Cells(j, "B")
                            Else
                                .Cells(c.Row, "C") = Cells(j, "C")
                            End If
                        End If
                        Set c = .[A:A].FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Adr
                End If
            Next j
        End With
    Next i

End Sub

evet değiştirmiştim sanırım değiştirmem gereken başka yerlerde kalmiş hala çalişmiyor.
 
Son düzenleme:
Böyle deneyiniz.:cool:
Kod: 
For i = 0 To 1
        With Sheets(syf(i))
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst