• DİKKAT

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

vba Sayfalara Komut Verme ?

R

Ruzgarxp

Katılım
20 Ağustos 2015
Mesajlar
8
Excel Vers. ve Dili
Türkçe ve İngilizce
Merhaba ;

vba da yazmak istediğim bir komut yeni başladığım için bilgim yok.

Sorum şöyle;

Bir hücereye eğer A2 de ( her satırda A3,A4...diye gidecek) herhangi bir değer var ise onu x sayfada düşeyara ( vlookup) formülü mantığında işlem yap.

Bu konuda bana yardımcı olabilir misiniz
 
Öncelikle çok teşekkür ederim dönüşünüz için.

Yeni başladığım için yönlerdiğiniz konudaki durumu tam anlayamadım.

Yapmak istediğimi manuel olarak excelde aşağıdaki formülle yapabiliyorum

=DÜŞEYARA(A2;AAA_Prefix_Vendors_Price_ALL!$A:$J;3;0)

şuanki ihtiyacımı vba lay çözmem gerektiğini düşünüyorum çünkü yaklaşık 200 sayfalık bir dosya.

yapmak istediğim

Dosyanın ilk sayfasında ülkeler ve telefon numaraları olduğu veriler mevcut bu tüm listenin dışındaki sayfalar ise listedeki her bir ülkeyi ve telefon numaraları içeriyor.

Yapmak istediğim her bir ülkeye ait sayfada A2 hücresinde veri var ise bunu ilk sayfadan bulup onun karşılığındaki değeri yazmasını istiyorum.

Çalışmanın örnek tablosunu aşağıdaki linkte örnek paylaşıyorum tabloda 2 sayfa ülke var ama ilk listedeki bütün ülkerin ayrı ayrı olduğunun düşünün yardımcı olursanız çok sevinirim. Çok teşekkürler.

https://www.dropbox.com/s/pfhobosqpra41te/deneme.xlsm?dl=0
 
Öncelikle çok teşekkür ederim dönüşünüz için.

Yeni başladığım için yönlerdiğiniz konudaki durumu tam anlayamadım.

Yapmak istediğimi manuel olarak excelde aşağıdaki formülle yapabiliyorum

=DÜŞEYARA(A2;AAA_Prefix_Vendors_Price_ALL!$A:$J;3; 0)

şuanki ihtiyacımı vba lay çözmem gerektiğini düşünüyorum çünkü yaklaşık 200 sayfalık bir dosya.

yapmak istediğim

Dosyanın ilk sayfasında ülkeler ve telefon numaraları olduğu veriler mevcut bu tüm listenin dışındaki sayfalar ise listedeki her bir ülkeyi ve telefon numaraları içeriyor.

Yapmak istediğim her bir ülkeye ait sayfada A2 hücresinde veri var ise bunu ilk sayfadan bulup onun karşılığındaki değeri yazmasını istiyorum.

Çalışmanın örnek tablosunu aşağıdaki linkte örnek paylaşıyorum tabloda 2 sayfa ülke var ama ilk listedeki bütün ülkerin ayrı ayrı olduğunun düşünün yardımcı olursanız çok sevinirim. Çok teşekkürler.

https://www.dropbox.com/s/pfhobosqpr...neme.xlsm?dl=0
 
bütün veriler bu dosyada mevcut mu yoksa daha var mı?
 
payleşmış olduğum ornek dosya orjinali yaklaşık 200 sayfa listedeki bütün ülkelerin sayfalara ayrılmış hali
 
Merhaba;

İlginiz yardımınız ve vakit ayırdığınız için tekrardan çok ederim.

Göndermiş olduğunuz kod tamda istediğim gibi çalışmakta.

Kodu çalıştırdığımda belirli bir sayfaya kadar yapıyor sonrasında ''Run-time error '6' : Overflow'' hatası veriyor.

Çalışma yaptığım orjinal dosyayı linkte paylaşıyorum.

https://www.dropbox.com/s/0z76fmwifanm962/Z_Prefix.xlsm?dl=0
 
düzeltilmiş kodları deneyiniz. (baya fazla veri olduğu için uzun sürüyor.)
Kod: 
Option Explicit
Sub fiyat()
Dim sh, sh_AAA As Worksheet
Dim ss, i As Long
[B][COLOR="Red"]Dim deger As String[/COLOR][/B]
Dim sonuc As Object
Dim adres, tmp_str As String
Application.ScreenUpdating = False

Set sh_AAA = Sheets("AAA_Prefix")


For Each sh In Worksheets
    If sh.Name <> "AAA_Prefix" Then
        sh.Select
        'AAA_Prefix_Vendors_Price_ALL adlı sayfa haricindeki tüm sayfalara gir
        
        'A sütunun son satır bilgisini bul
        ss = sh.Cells(65536, 1).End(xlUp).Row
        
        'her bir değeri AAA sayfasında ara
        For i = 2 To ss
        [COLOR="red"][B]If sh.Cells(i, 3).Value <> "" Then[/B][/COLOR]
            deger = sh.Cells(i, 1).Value  'bulunacak değer
            sh_AAA.Select
            'Arama işlemini gerçekleştir
            Set sonuc = sh_AAA.Range("A:A").Find(deger, , xlValues, xlWhole)
            'arama sonucu bulunduysa
            If Not sonuc Is Nothing Then
                tmp_str = sonuc.Address(ColumnAbsolute:=False)
                adres = Split(tmp_str, "$")
                tmp_str = "C" & adres(1) & ":" & "J" & adres(1)
                sh_AAA.Range(tmp_str).Select
                Selection.Copy
                sh.Activate
                sh.Range("C" & i).Select
                ActiveSheet.Paste
            End If
            
            Set sonuc = Nothing
        End If
        Next
        
    End If
Next

Application.ScreenUpdating = True
End Sub
 
Merhaba,

Sütunlardaki #YOK yazan verilerin bir önemi yoksa aşağıdaki kodu kullanabilirsiniz.

Kod: 
Option Explicit

Sub Sayfalarda_Duseyara()
    Dim S1 As Worksheet, S2 As Worksheet, Sayfa As Worksheet
    Dim Zaman As Double, Dizi As Variant, X As Long, Satir As Long, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Set S1 = Sheets("AAA_Prefix")
    
    S1.Range("C2:K" & S1.Rows.Count).ClearContents
    Sheets.Add , S1
    Set S2 = ActiveSheet
    Satir = 1
    
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> S1.Name And Sayfa.Name <> S2.Name Then
            Sayfa.Range("A1").CurrentRegion.Copy S2.Cells(Satir, 1)
            If Satir > 1 Then S2.Rows(Satir).Delete
            Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
            S2.Range("K" & Satir & ":K" & Son) = Sayfa.Name
            Satir = Son + 1
        End If
    Next
    
    S2.Range("A1").CurrentRegion.SpecialCells(xlCellTypeConstants, 16) = "XXXX"

    Dizi = S2.Range("A1").CurrentRegion.Resize(, 11).Value
    
    With CreateObject("Scripting.Dictionary")
        For X = 2 To UBound(Dizi, 1)
            .Item(Dizi(X, 1)) = Dizi(X, 2) & "#" & Dizi(X, 3) & "#" & Dizi(X, 4) & "#" & Dizi(X, 5) & "#" & Dizi(X, 6) & _
                                "#" & Dizi(X, 7) & "#" & Dizi(X, 8) & "#" & Dizi(X, 9) & "#" & Dizi(X, 10) & "#" & Dizi(X, 11)
        Next
        
        Dizi = S1.Range("A1").CurrentRegion.Resize(, 11).Value
        
        On Error Resume Next
        
        For X = 2 To UBound(Dizi, 1)
            If .Exists(Dizi(X, 1)) Then
                Dizi(X, 3) = CDbl(Split(.Item(Dizi(X, 1)), "#")(1))
                Dizi(X, 4) = CDbl(Split(.Item(Dizi(X, 1)), "#")(2))
                Dizi(X, 5) = CDbl(Split(.Item(Dizi(X, 1)), "#")(3))
                Dizi(X, 6) = CDbl(Split(.Item(Dizi(X, 1)), "#")(4))
                Dizi(X, 7) = CDbl(Split(.Item(Dizi(X, 1)), "#")(5))
                Dizi(X, 8) = CDbl(Split(.Item(Dizi(X, 1)), "#")(6))
                Dizi(X, 9) = CDbl(Split(.Item(Dizi(X, 1)), "#")(7))
                Dizi(X, 10) = CDbl(Split(.Item(Dizi(X, 1)), "#")(8))
                Dizi(X, 11) = Split(.Item(Dizi(X, 1)), "#")(9)
            End If
        Next
    End With
    
    S1.Range("A2:A" & S1.Rows.Count).NumberFormat = "@"
    S1.Range("A1").CurrentRegion.Resize(, 11) = Dizi
    
    Application.DisplayAlerts = False
    S2.Delete
    Application.DisplayAlerts = True
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00")
End Sub
 
Merhaba ;

Öncelikle terar dan çok teşekkür ederim.
İzne çıktığım için ilginememdim şimdi döndüğümde denedim çalışıyor. Elinize sağlık. Ben daha çok network tarafında bilgiliyim eğer bir sorunuz olursa bana danışabilirsiniz.
Mail : ugurfiratt@gmail.com

Size sormak istediğim bir sorum daha var yardımcı olabilirseniz tekrardan çok memnun olurum.

C2:I2 hücrelerindeki sayı değerlerinin en küçüklerinden 3 tanesinin ortalamasını almasını istiyorum.

yapmak istediğim çalışma paylşatığım dosyadaki Ortalam_Değer _ve_Fiyat_Çıkarma sayfasında.

Dosya tam haliyle ekte sizlerde yapmak istediğim çalışmayı anlayabilirsiniz eğer uğraştığım ve VBA çözümü olan başka bir öneriniz olursa suınabilireniz çok sevinirim.

Tekrardan çok teşekkürler.

linkteki dosyayı paylaşıyorum

http://www.dosya.tc/server3/wirrna/EE_Calisiyor_Prefix.rar.html
 
J2 hücresine aşağıdaki dizi formülü uygulayıp deneyiniz.

Kod: 
=ORTALAMA(KÜÇÜK(EĞER(ESAYIYSA(C2:I2);C2:I2);EĞER(TOPLA.ÇARPIM(--ESAYIYSA(C2:I2))<3;SATIR(DOLAYLI("A1:A"&TOPLA.ÇARPIM(--ESAYIYSA(C2:I2))));{1;2;3})))

Formülü hücreye yazdıktan sonra hücreyi CTRL+SHIFT+ENTER tuşlarına basarak terk ediniz. Aksi halde doğru sonuç üretmez.
 
aşağıdaki kodları yeni bir module içine yazıp deneyiniz.
Kod: 
Sub enKucukDegerOrtalama()
Dim sh As Worksheet
Dim dizi(), tmpDizi() As Double
Set sh = Worksheets("Ortalam_Değer _ve_Fiyat_Çıkarma")
ss = sh.Range("A100000").End(xlUp).Row


For i = 2 To ss
    adet = 0
    ReDim dizi(7)
    For j = 3 To 9
        deger = sh.Cells(i, j)
        If IsNumeric(deger) Then
            adet = adet + 1
            dizi(adet) = deger
        End If
    Next j
    
    Select Case adet
    Case 0
        sonuc = 0
    Case 1
        sonuc = dizi(1)
    Case 2
        sonuc = (dizi(1) + dizi(2)) / 2
    Case 3
        sonuc = (dizi(1) + dizi(2) + dizi(3)) / 3
    Case 4 To 7
        ReDim tmpDizi(adet - 1)
        For xi = 0 To adet - 1
            tmpDizi(xi) = dizi(xi)
        Next xi
    
        For xi = LBound(tmpDizi) To UBound(tmpDizi)
            For xj = xi + 1 To UBound(tmpDizi)
                If tmpDizi(xi) > tmpDizi(xj) Then
                    SrtTemp = tmpDizi(xj)
                    tmpDizi(xj) = tmpDizi(xi)
                    tmpDizi(xi) = SrtTemp
                End If
            Next xj
        Next xi

        k1 = dizi(1)
        k2 = dizi(2)
        k3 = dizi(3)
        sonuc = (k1 + k2 + k3) / 3
    Case Else
        sonuc = "HATA"
    End Select
    sh.Range("J" & i) = sonuc
Next i

End Sub
 
Yardımlarınız çok teşekkür ederim kod ve förmülde tam istediğim gibi çalıştı. Elinize sağlık. Önceden de bahsettiğim gibi network le ilgili eğer size yardımcı olabileceğim bir konu olursa muhakkak bana ulaşın.
 
birşey değil, networkle ilgili maddi bir sıkıntım olursa ararım bak :)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst