• DİKKAT

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

Sayfalararası Aktarımı nasıl yapabilirim?

A

assenucler

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,588
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Pro x64 TR
Değerli üstadlarım;


İyi akşamlar.


Ekli excel dosyamda "Mizan, Mizan Yeni, Borçlu Alacaklı" adıyla 3 ayrı sayfam var.

"Mizan" sayfasında bir programdan yaratılan veriler bulunmaktadır. Bu sayfanın "A" sütunundaki verilerin tamamı ile "B" sütunundakilerin sadece "Ad Soyad" kısmını; "Mizan Yeni" sayfasına aktarılmasını;

Daha sonra da, gerçek doğru verilerin bulunduğu "Borçlu Alacaklı" sayfasındaki tutarların, bu kez "Mizan Yeni" sayfasındaki sütunlara aktarılmasını istiyorum.İstediklerimi resimle de anlatmaya çalıştım.



Bu işlerin makro ya da fonksiyonla yapılması konusunda değerli yardımlarınızı rica ediyorum.
 

Ekli dosyalar

Son düzenleme:
. . .

Kod: 
Sub kod_bir()
Dim sm As Worksheet
Dim smy As Worksheet
Dim sba As Worksheet
Dim i, h
Set sm = Sheets("mizan")
Set smy = Sheets("Mizan Yeni")
Set sba = Sheets("Borçlu Alacaklı")
Application.ScreenUpdating = False

smy.Range("a2:g65536").ClearContents
aa = sm.[a65536].End(3).Row
sm.Range("A2:B" & aa).Copy

Sheets("Mizan Yeni").Select
Range("A2").PasteSpecial Paste:=xlPasteValues
bb = smy.[a65536].End(3).Row
Application.CutCopyMode = False
Range("B2:B" & bb).Replace What:="*   ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

cc = sba.[a65536].End(3).Row
For i = 2 To bb
For h = 2 To cc
If smy.Cells(i, "a") = "120." & sba.Cells(h, "b") Then
smy.Cells(i, "c") = sba.Cells(h, "d")
smy.Cells(i, "d") = sba.Cells(h, "e")
smy.Cells(i, "e") = sba.Cells(h, "f")
smy.Cells(i, "f") = sba.Cells(h, "g")
Else
End If
Next h
Next i

Application.ScreenUpdating = True
MsgBox " B İ T T İ "
End Sub
. . .
 
Teşekkür

Değerli üstadım iyi akşamlar.

Katkınız ve yardımınız için teşekkürler.

Bilgisizliğimi mazur görün lütfen.

Bu kodu nasıl kullanmam konusunda bilgi verebilir misiniz?

Sevgi ve saygılar.
 
. . .

Kodları boş bir modüle yapıştırın. Daha sonra bir butona atayarak çalıştırabilirsiniz.

. . .
 
Alternatif:
Kod: 
Sub Emre()
    Dim i As Integer
    Dim bul As Range
        For i = Sayfa1.Range("A65536").End(3).Row To 2 Step -1
            Sayfa2.Cells(i, 1) = Sayfa1.Cells(i, 1)
            Sayfa2.Cells(i, 2) = Mid(Sayfa1.Cells(i, 2), 15, 31)
            Cells(i, 2) = LTrim(Cells(i, 2))
        For Each bul In Sayfa2.Range("B2:B61")
        If bul.Value = Sayfa3.Cells(i, 1) Then
            bul.Offset(0, 1).Value = Sayfa3.Cells(i, 4)
            bul.Offset(0, 2).Value = Sayfa3.Cells(i, 5)
            bul.Offset(0, 3).Value = Sayfa3.Cells(i, 6)
            bul.Offset(0, 4).Value = Sayfa3.Cells(i, 7)
        End If
        Next bul
        Next i
    Set bul = Nothing: i = Empty
End Sub
Herhangi bir sayfadayken, Alt + F11 tuş kombinasyonlarına birlikte basın.
Yeni bir pencere açılacak ve o pencerenin üst kısmında, File - Edit - View - Insert menülerini göreceksiniz.
Oradaki Insert menüsünü seçin ve açılan menüden Module'e basın.
Sonrada verdiğim kodları oraya kopyalayın ve dilerseniz o penceredeyken F5 tuşuna basın.
Ya da sayfaya dönün ve sayfaya bir buton ekleyin.
Butonun üzerinde sağ tıklayın, Makro Ataya basın, açılan pencereden de Emre'yi seçip Tamam butonuna basın.
Son olarak sayfaya eklediğiniz butonu tıklayın.

İyi geceler...
 
Sayın Murat Osma;

Üstadım, iyi geceler.. İyi ki varsınız. Yardımınız için içten teşekkürler.

Sevgi ve saygılarımla.
 
Rica ederiz Ahmet Bey,

Hoşça kalın !!!
 
2 satırın Ad Soyadı'nı aktarmıyor.

Sayın Hüseyin Çoban;


Üstadım günaydın ve hayırlı işler. Kodları bir düğmeye bağlayıp uyguladığımda, "B05" daire mal sahibi ve kiracının "Ad Soyad" sütunu boş çıkıyor.

Bir kaç saattir uğraşmama karşın, sorunun kaynağını bulamadım.

Sorun neden kaynaklanabilir?

Teşekkürler.
 

Ekli dosyalar

assenucler' Alıntı:
Sayın Hüseyin Çoban;


Üstadım günaydın ve hayırlı işler. Kodları bir düğmeye bağlayıp uyguladığımda, "B05" daire mal sahibi ve kiracının "Ad Soyad" sütunu boş çıkıyor.

Bir kaç saattir uğraşmama karşın, sorunun kaynağını bulamadım.

Sorun neden kaynaklanabilir?

Teşekkürler.
Genişletmek için tıkla ...
. . .

120.B05 kodunun karşısındaki isimlerin sonunda 3 karakter boşluk bırakılmış.

Ben kodlamada,
B BLOK - B04(3 karakter boşluk)TULUĞ ÖZERİNÇİL
isimler ve hesap kodları arasındaki 3 boşluğa göre kriter belirledim.
O isimlerin ortasında ve sonunda da 3 karakter boşluk olunca, hatalı işlem yapıyor.

120.B05 karşısındaki isimlerin sonundaki boşlukları, düzeltmelisiniz.

. . .
 
. . .

120.B05 mükerrer olduğu için, tutarlarını hatalı getiriyor.

Veya isimlerde düzeltme yapmadan, kodlama mantığı değişebilir. What:="*BLOK* "
aşağıdaki şekilde deneyiniz.

Kod: 
Sub kod_bir()                       'Hüseyin Çoban çözümü
Dim sm As Worksheet
Dim smy As Worksheet
Dim sba As Worksheet
Dim i, h
Set sm = Sheets("mizan")
Set smy = Sheets("Mizan Yeni")
Set sba = Sheets("Borçlu Alacaklı")
Application.ScreenUpdating = False

smy.Range("a2:g65536").ClearContents
aa = sm.[a65536].End(3).Row
sm.Range("A2:B" & aa).Copy

Sheets("Mizan Yeni").Select
Range("A2").PasteSpecial Paste:=xlPasteValues
bb = smy.[a65536].End(3).Row
Application.CutCopyMode = False
Range("B2:B" & bb).Replace What:="*BLOK*   ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

cc = sba.[a65536].End(3).Row
For i = 2 To bb
For h = 2 To cc
If smy.Cells(i, "a") = "120." & sba.Cells(h, "b") Then
smy.Cells(i, "c") = sba.Cells(h, "d")
smy.Cells(i, "d") = sba.Cells(h, "e")
smy.Cells(i, "e") = sba.Cells(h, "f")
smy.Cells(i, "f") = sba.Cells(h, "g")
Else
End If
Next h
Next i

Application.ScreenUpdating = True
MsgBox " B İ T T İ "
End Sub
 
Üstadım, yukarıdaki kodu module ekledim. Ancak şöyle bir durum oluşuyor. WHAT:="*BLOK* " kullanıldığında, örneğin "A02" nolu dairenin mal sahibi ile kiracısının (Borcu, Ödemesi, BBakiye, ABakiye) tutarlarını ayrı ayrı "Mizan Yeni" sayfasına aktarmıyor, sadece tek bir kişinin kaydını aktarıyor.

Size büyük zahmet verdiğimin farkındayım. Değerli zamanınızı daha fazla almak istemiyorum.

Sevgi ve saygılar.
 
. . .

Aşağıdaki kodları deneyiniz.

Kod: 
Sub kod_bir()                       'Hüseyin Çoban çözümü
Dim sm As Worksheet
Dim smy As Worksheet
Dim sba As Worksheet
Dim i, h
Set sm = Sheets("mizan")
Set smy = Sheets("Mizan Yeni")
Set sba = Sheets("Borçlu Alacaklı")
Application.ScreenUpdating = False

smy.Range("a2:g65536").ClearContents
aa = sm.[a65536].End(3).Row
sm.Range("A2:B" & aa).Copy

Sheets("Mizan Yeni").Select
Range("A2").PasteSpecial Paste:=xlPasteValues
bb = smy.[a65536].End(3).Row
Application.CutCopyMode = False
Range("B2:B" & bb).Replace What:="*BLOK*   ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

cc = sba.[a65536].End(3).Row
For i = 2 To bb
For h = 2 To cc
If smy.Cells(i, "a") = "120." & sba.Cells(h, "b") And _
smy.Cells(i, "b") Like "*" & sba.Cells(h, "a") & "*" Then
smy.Cells(i, "c") = sba.Cells(h, "d")
smy.Cells(i, "d") = sba.Cells(h, "e")
smy.Cells(i, "e") = sba.Cells(h, "f")
smy.Cells(i, "f") = sba.Cells(h, "g")
Else
End If
Next h
Next i

Application.ScreenUpdating = True
MsgBox " B İ T T İ "
End Sub

. . .
 
Son düzenleme:
Değerli üstadım, sonuç süper oldu, her şey gönlünüzce olsun.

İstanbul'dan en içten sevgi ve saygılarımı sunarım.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst