• DİKKAT

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

satırdaki değere göre diğer sayfaya farklı verileri aktarma

E

eneskus

Katılım
22 Ocak 2010
Mesajlar
112
Excel Vers. ve Dili
2007 türkçe
Herkeze kolay gelsin.

YENİ MAL. MUT. sayfasındaki a sütunundaki no değeri veri sayfasında a sütununda var bu sıra noyu baz alarak YENİ MAL. MUT. sayfasındaki örneğin 1. sıra nolu yani a45 oluyor satırda sayı girilmiş hüçrenin sütınundaki malzeme ismini ve girilen sayıyı veri sayfasında x den başlayarak aynı satıra nasıl yazdırabiliriz.

yardımlarınız için teşekkürler.
 

Ekli dosyalar

abi istediğiniz olabilecek birşey ama sanırım anlatımı biraz daha görsel halde sunsanız, zira tablonuzda zaten cok veri kafası karışıyor insanın :)
 
talebeyim' Alıntı:
abi istediğiniz olabilecek birşey ama sanırım anlatımı biraz daha görsel halde sunsanız, zira tablonuzda zaten cok veri kafası karışıyor insanın :)
Genişletmek için tıkla ...

evet haklısınız.

örneğin 1 sıra numaralı olan 45. satırda 9mt emperyalı çam ağaç direk dengine kesişim noktasına 1 yazdığımda veri sayfasına 9mt emperyalı çam ağaç direk ve 1 i yazması lazım.
 
Farklı bir şekilde anlatmak gerekirse.


- Aktar dümesine tıkladığımızda
- yeni mal. mut. sayfası d45 ile gl45 arasında değer varmı diye bakacak değer varsa ( bu encok 6 adet olabilir altıdan fazla ise uyarı vermesi gerekmekte)
- Tarama soldan sağa doğru olacak
- ilk değer olan hüçredeki değeri veri sayfasın de y2 ye yazacak ve bulunan değer ile aynı sütundaki 4 satırdaki malzeme ismini de veri sayfasın de x2 ye yazacak

ve

Yeni mal. mut. de aramaya devam edecek 45. satırda aramaya devam edecek sonraki değer bulduğundada bu değeri veri sayfasın de z2 ye yazacak ve bulunan değerle aynı sütundaki 4. satırdaki malzeme ismini veri sayfasındaki aa2 ye yazacak.

45. satır bittimi 46. satıra gececek ve bu 1244. satıra kadar devam edecek.

Yardımlarınız için şimdiden teşekkürler.
 
sub aktar ()
Dim S1 As Worksheet, S2 As Worksheet
Set S1 = Sheets("veri")
Set S2 = Sheets("yeni mal. mut.")
Yeni mal. mut. 45. satır da 4. sütun (d sütunundan) 194. sütun (gl sütununa) kadar değer varmı diye bakacak.
Değer varsa yeni mal. mut. de a45 de yazılı sıra numarasını veri de a2:a arasında bulucak ve
değer olan hüçredeki değeri veride y sütunu ( 25. sütun) na yazacak.
Yeni mal. mut.de bulunan değer hangi sütunda ise o sütunun 4. satırındaki malzeme ismini
veride x sütunu ( 24. sütun) na yazacak.
Yeni mal. mut.de 45. satırda değer aramaya devam edecek sonraki bulduğu değerler saygfa 1 de sırasıyla aa,ac,ae,ag ve aı sütunlarına yazacak.
Malzeme ismini de veri de z,ab,ad,af ve ah yazacak.
6 dan fazla değer varsa yeni mal. mut. de o satırı komple sarıya boyasın ancak 6 dan fazla değeri aktaramıyacak veya aktarmıyacak.
45. satırdaki işlemler bittimi 46. satıra gececek ve bu 1244. satıra kadar devam edecek

end sub
 
Merhaba,

Aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, X As Integer, Adet As Integer
    Dim Say As Integer, Satir As Long, Sutun As Byte, Veri As Range
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YENİ MAL. MUT.")
    Satir = 2
    Sutun = 24
 
    S1.Range("X2:AI1201").ClearContents
    S2.Range("A45:GL1244").Interior.ColorIndex = xlNone
 
    For X = 45 To 1244
        Say = WorksheetFunction.CountA(S2.Range("D" & X & ":GL" & X))
        If Say > 0 And Say < 7 Then
            For Each Veri In S2.Range("D" & X & ":GL" & X).SpecialCells(xlCellTypeConstants, 23)
                S1.Cells(Satir, Sutun) = S2.Cells(4, Veri.Column)
                Sutun = Sutun + 1
                S1.Cells(Satir, Sutun) = Veri.Value
                Sutun = Sutun + 1
            Next
        ElseIf Say > 6 Then
            Adet = Adet + 1
            S2.Range("A" & X & ":GL" & X).Interior.ColorIndex = 6
        End If
        Sutun = 24
        Satir = Satir + 1
    Next
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "Toplam ; " & Adet & " satırda 6 adetten fazla veri bulunmaktadır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Merhaba,

Aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, X As Integer, Adet As Integer
    Dim Say As Integer, Satir As Long, Sutun As Byte, Veri As Range
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YENİ MAL. MUT.")
    Satir = 2
    Sutun = 24
 
    S1.Range("X2:AI1201").ClearContents
    S2.Range("A45:GL1244").Interior.ColorIndex = xlNone
 
    For X = 45 To 1244
        Say = WorksheetFunction.CountA(S2.Range("D" & X & ":GL" & X))
        If Say > 0 And Say < 7 Then
            For Each Veri In S2.Range("D" & X & ":GL" & X).SpecialCells(xlCellTypeConstants, 23)
                S1.Cells(Satir, Sutun) = S2.Cells(4, Veri.Column)
                Sutun = Sutun + 1
                S1.Cells(Satir, Sutun) = Veri.Value
                Sutun = Sutun + 1
            Next
        ElseIf Say > 6 Then
            Adet = Adet + 1
            S2.Range("A" & X & ":GL" & X).Interior.ColorIndex = 6
        End If
        Sutun = 24
        Satir = Satir + 1
    Next
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "Toplam ; " & Adet & " satırda 6 adetten fazla veri bulunmaktadır.", vbInformation
End Sub
Genişletmek için tıkla ...

ALLAH razı olsun çok teşekkürler Korhan Bey.
 
Korhan bey tekrardan çok teşekkürler.

1 sorum daha olacak konuyu anladığınız için uzunca anlatmıyacam sizin yapmış olduğunuz makro yeni mal. mut. sayfasındaki tablodan adet ve malzeme isimlerini veri sayfasına aktarmaktaydı.

bunun tam tersi için yani veri sayfasındaki malzeme isimleri ve adetleri yeni mal. mut. sayfasına nasıl aktarabiliriz.

Aslında arkadaşlar bu konu ile ilgili birkaç kod vermişleridi ancak bu kodlar ya cok kasıyor bilgisayarı yada veri değişmesiyle aktif olan makrolar. Ben makroyu butona aklemek istemekteyim.

birde sizin yapmış olduğunuz makro gercekten cok hızlı, aynı hızda tam tersi olsa cokk memnun olurum.
 
Merhaba,

Kaydetme mantığı ne düzende olacak?

"YENİ MAL. MUT." isimli sayfanızda TARİH-NO bilgileri var. Bunlar neye göre doldurulacak?
 
ilginiz için gercekten teşekkürler korhan bey.
tarih ve no bilgilerini veri sayfasından hüçre bağlama yoluyla ben girdirecem.
yapmak istediğimi anlatmaya calıştım:

sub aktar ()
Dim S1 As Worksheet, S2 As Worksheet
Set S1 = Sheets("veri")
Set S2 = Sheets("yeni mal. mut.")
s1 sayfası x2 ile ah2 arası x,z,ab,ad,af ve ah yani (24,26,28,30,32 ve 34 nolu sütünlar) veri (malzeme ismi) varmı diye bakacak.
Örneğin x2 de veri varsa veriyi (bu veri malzeme ismi oluyor) s2 sayfası d4 ile gl4 arası arayacak, bulduğu sütun ile s1 x2 nin sıra numarası a2 de yazılı bu sıra numarasını s2 a45 il a1244 arası arayacak ve bulduğu satır ve sütünun kesişimine s1 sayfası y2 hüçresinde yazan adeti yazacak ve arama bu şekilde devam edecek
 
Merhaba,

Aşağıdaki kodu deneyin.

Kod: 
Option Explicit
 
Sub AKTAR_2()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Y As Byte
    Dim BUL_MALZEME As Range, BUL_NO As Range
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YENİ MAL. MUT.")
 
    S2.Range("D45:GL1244").ClearContents
 
    For X = 2 To 1200
        For Y = 24 To 34 Step 2
            If S1.Cells(X, Y) <> "" Then
                Set BUL_MALZEME = S2.Rows("4:4").Find(S1.Cells(X, Y), , xlValues)
                If Not BUL_MALZEME Is Nothing Then
                    Set BUL_NO = S2.Range("A43:A1244").Find(S1.Cells(X, 1), , , xlWhole)
                    If Not BUL_NO Is Nothing Then
                        S2.Cells(BUL_NO.Row, BUL_MALZEME.Column) = S1.Cells(X, Y + 1)
                    End If
                End If
            End If
            Set BUL_MALZEME = Nothing
            Set BUL_NO = Nothing
        Next
    Next
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan bey malesef aktarmadı.
İşleminiz tamamlanmıştır.
demekte ancak aktarmıyor malesef.
 
Merhaba,

"YENİ MAL. MUT." isimli sayfanızdaki birleştirilmiş hücreler sorun yaratıyor. 5. satırı silip üstteki yenilediğim kodu deneyin. Silinen satır yerine 7. satırdan itibaren boş bir satır ekleyin.
 
Korhan bey bütün birleştirilmiş hüçreleri ayırdım dediğiniz gibi 5. satır silindi 7. satırdan sonra 1 satır daha ekledim ancak yine olmadı malesef.
 
Merhaba,

Ekteki örnek dosyayı inceleyiniz.
 

Ekli dosyalar

Çok teşekkürler çalışıyor. Ben neden çalıştıramamışım bilmiyorum. konu dışı ancak yeni konu açmaktansa buradan sorayım dedim. Aşağıdaki kod ile kapalı dosyadan filitre ederek veri almaktayım.
Ancak dosya açılıyor verileri alıyor ve veri.xlsm dosyasındaki değişiklikleri kaydetmek istiyormusunuz diye soruyor.
değişiklik yapmadan kapatacak şekilde nasıl ayarlaya biliriz acaba.
Kod: 
Sub AUTO_OPEN()
    Dim c As Range, sat As Long, ilkadres As Variant
    Dim Uygulama As Application, dosya As Workbook

    Sheets(1).Select
    Range("B2:BC" & Rows.Count).ClearContents
    sat = 2
    
    Set Uygulama = CreateObject("Excel.Application")
    Set dosya = Uygulama.Workbooks.Open(ThisWorkbook.Path & "\VERİ.xlsm")
    Uygulama.Visible = False
    
    With dosya.Sheets("VERİ").Range("d:d")
        Set c = .Find(ActiveSheet.Name, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            ilkadres = c.Address
            Do
                Range("b" & sat & ":BC" & sat).Value = dosya.Sheets("VERİ").Range("A" & c.Row & ":BB" & c.Row).Value
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> ilkadres
        End If
    End With
    
    Uygulama.Quit

End Sub
 
Merhaba,

"Uygulama.Quit" ifadesinin bir üst satırına aşağıdaki kodu ekleyip deneyin.

Kod: 
dosya.Close 0
 
Çok çok teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst