• DİKKAT

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

Tablo aktarım

  • Konbuyu başlatan Konbuyu başlatan Barons
  • Başlangıç tarihi Başlangıç tarihi
B

Barons

Altın Üye
Katılım
14 Mayıs 2005
Mesajlar
967
Excel Vers. ve Dili
Microsoft Ofis 365
Merhaba
SP sayfasındaki gri renkli hücreleri depo sayfasına aktarmak istiyorum.Bu gri bölgelerden B9:N39 arasında 1 veride olabilir,31 veride olabilir.Ayrıca buradaki hücrelerin tamamında orjinal dosyada formul mevcut.yardımcı olacak arkadaşa kolaylık olması amacıyla pembe kısımda irtibat adreslerini verdim.Aslında aktar makrosu mevcut ama mükerrer aktarma yapıyor.

ikinci olarakda depo sayfasına aktarılan bilgileri,SP sayfasında J3 hücresi baz alınarak geri çağırmak istiyorum.

Yardımcı olacak arkadaşlara sonsuz teşekkürler
 

Ekli dosyalar

  • a.xls
    a.xls
    67.5 KB · Görüntüleme: 38
tekrar merhaba

daha öncede bu problemi sormuştum ve çözülememişti...demekki Excelde kodla çözülemeyen problemlerde oluyormuş...
 
Ustadlar şu dosyadaki makro koduna bir el atıverin...belki ufak bir düzenlemeyle olur diye ümid ediyorum...
 
Selamlar,

Aktarım için kullandığınız kodu aşağıdaki şekilde değiştirip denermisiniz.

J3 hücresindeki fatura numarasına göre veri çağırılabilir. Fakat gri renkli alanda formül olduğunu belirtmişsiniz. Bu durumda veriler makro ile çağrılırken formülleriniz silinecektir.


Kod: 
Sub AKTAR()
    Dim S1 As Worksheet
    Dim S2 As Worksheet
    Dim X As Integer, Satır As Long
 
    Set S1 = Sheets("SP")
    Set S2 = Sheets("DEPO")
 
    If WorksheetFunction.CountIf(S2.Range("G:G"), Range("J3")) > 0 Then
    MsgBox "Bu kayıt daha önce yapılmıştır. İşleminiz iptal edilmiştir.", vbCritical
    Exit Sub
    End If
 
    Application.ScreenUpdating = False
    S2.Select
    Satır = Range("A65536").End(3).Row + 1
 
    For X = 9 To 39
        If S1.Cells(X, 2) <> "" Then
            Cells(Satır, 1) = Satır - 1
            Cells(Satır, 2) = S1.Range("Q1")
            Cells(Satır, 3) = S1.Range("A1")
            Cells(Satır, 4) = S1.Range("A2")
            Cells(Satır, 5) = S1.Range("A3")
            Cells(Satır, 6) = S1.Range("I3")
            Cells(Satır, 7) = S1.Range("J3")
            Cells(Satır, 8) = S1.Range("Q2")
            Cells(Satır, 9) = S1.Range("Q3")
            Cells(Satır, 10) = S1.Range("V4")
            Cells(Satır, 11) = S1.Range("I6")
            Cells(Satır, 12) = S1.Range("I8")
            Range("M" & Satır & ":W" & Satır).Value = S1.Range("B" & X & ":L" & X).Value
            Cells(Satır, 24) = S1.Cells(X, 14)
            Cells(Satır, 25) = S1.Range("Z1")
            Satır = Satır + 1
        End If
    Next
    Application.ScreenUpdating = True
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    MsgBox "Verileriniz başarıyla kaydedilmiştir."
End Sub
 
çok çok teşekkürler..süper elinize sağlık...2nci durum çok daha önemli benim için...formulun silinmesi önemli değil...tüm formulleri yedek diye bir sayfadan geri getiriyorum...
geri çağırma işide hallolursa çok minnettar kalacağım..tekrar elinize sağlık...
sağlık,huzur maddi manevi kazançlar diliyorum.
 
Sn Korhan,

Aktar makrosunda depo sayfasına (fatura no baz alınarak) mükerrer girişi engellemek mümkünmüdür?
Teşekkürler
 
Selamlar,

Mükerrer kayıdı önlemek için #4 nolu mesajımdaki kodu güncelledim. Deneyiniz.

Ayrıca J3 hücresine giriş yaparak veri almak içinde SP isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayıp deneyiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BUL As Range, ADRES As String, Satır As Long
    
    If Intersect(Target, [J3]) Is Nothing Then Exit Sub
    If Target <> "" Then
    Range("A1:K1,A2:E3,I3:I5,Q1:U3,B9:N39,Z1") = Empty
    Satır = 9
    
    Set BUL = Sheets("DEPO").Range("G:G").Find(Target, LookAt:=xlWhole)
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
        Range("A1") = Sheets("DEPO").Cells(BUL.Row, 3)
        Range("A2") = Sheets("DEPO").Cells(BUL.Row, 4)
        Range("A3") = Sheets("DEPO").Cells(BUL.Row, 5)
        Range("I3") = Sheets("DEPO").Cells(BUL.Row, 6)
        Range("Q1") = Sheets("DEPO").Cells(BUL.Row, 2)
        Range("Q2") = Sheets("DEPO").Cells(BUL.Row, 8)
        Range("Q3") = Sheets("DEPO").Cells(BUL.Row, 9)
        Range("V4") = Sheets("DEPO").Cells(BUL.Row, 10)
        Range("I6") = Sheets("DEPO").Cells(BUL.Row, 11)
        Range("I8") = Sheets("DEPO").Cells(BUL.Row, 12)
        Range("B" & Satır & ":M" & Satır).Value = Sheets("DEPO").Range("M" & BUL.Row & ":W" & BUL.Row).Value
        Range("N" & Satır) = Sheets("DEPO").Cells(BUL.Row, 24)
        Range("Z1") = Sheets("DEPO").Cells(BUL.Row, 25)
        Satır = Satır + 1
    Set BUL = Sheets("DEPO").Range("G:G").FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    Set BUL = Nothing
    
    Else
    
    MsgBox "Aradığınız fatura no bulunamamıştır !", vbExclamation
    End If
    End If
End Sub
 
ne diyeyim bilmemki...çok çok teşekkürler...süper olmuş...beni bir sıkıntıdan kurtardınız..Rabbim misliye size güzellikler nasip etsin...
sadece bir sorum olacak Korhan hocam, bu kodu sayfanın kod sayfasına değilde bir düğmeye bağlamak dahamı iyi olur acaba ve kodda ne gibi değişiklik gerekir o zaman...neden derseniz buraya veri girişi yapılacak sürekli ve sayfa devamlı tetiklenecek değilmi..bu sebeple bu makroyu bir düğmeye bağlamak mümkünmü acaba?
 
Selamlar,

Aşağıdaki kodu bir butona atayıp deneyiniz.

Sayfaya ait kodu silmeyi unutmayın.

Kod: 
Option Explicit
 
Sub FATURA_BUL()
    Dim BUL As Range, ADRES As String, Satır As Long
    
    If Range("J3") <> "" Then
    
    Range("A1:K1,A2:E3,I3:I5,Q1:U3,B9:N39,Z1") = Empty
    Satır = 9
    
    Set BUL = Sheets("DEPO").Range("G:G").Find(Range("J3"), LookAt:=xlWhole)
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
        Range("A1") = Sheets("DEPO").Cells(BUL.Row, 3)
        Range("A2") = Sheets("DEPO").Cells(BUL.Row, 4)
        Range("A3") = Sheets("DEPO").Cells(BUL.Row, 5)
        Range("I3") = Sheets("DEPO").Cells(BUL.Row, 6)
        Range("Q1") = Sheets("DEPO").Cells(BUL.Row, 2)
        Range("Q2") = Sheets("DEPO").Cells(BUL.Row, 8)
        Range("Q3") = Sheets("DEPO").Cells(BUL.Row, 9)
        Range("V4") = Sheets("DEPO").Cells(BUL.Row, 10)
        Range("I6") = Sheets("DEPO").Cells(BUL.Row, 11)
        Range("I8") = Sheets("DEPO").Cells(BUL.Row, 12)
        Range("B" & Satır & ":M" & Satır).Value = Sheets("DEPO").Range("M" & BUL.Row & ":W" & BUL.Row).Value
        Range("N" & Satır) = Sheets("DEPO").Cells(BUL.Row, 24)
        Range("Z1") = Sheets("DEPO").Cells(BUL.Row, 25)
        Satır = Satır + 1
    Set BUL = Sheets("DEPO").Range("G:G").FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    Set BUL = Nothing
    
    Else
    
    MsgBox "Aradığınız fatura no bulunamamıştır !", vbExclamation
    End If
    End If
End Sub
 
Çok Teşekkürler Sn.Korhan..Kronik bir problemimi çözdünüz...elinize sağlık...her 2 kodda çok güzel çalışıyor
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst