• DİKKAT

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

Koşula Göre Veri Aktarma

B

Bakigemlik

Altın Üye
Katılım
16 Ocak 2013
Mesajlar
674
Excel Vers. ve Dili
2010 Türkçe
Merhaba Üstatlar,

Öncelikle cümlemizin bu değerli günü kutlu olsun,

Soruma gelince ek dosyada "O" sütununda ki değer Spota eşitse ve "BG" de hücre boşsa buradaki verileri boşlar sayfasına aktarılması için desteğinizi rica ederim,

Aktarılması gereken sütunlar ,

Değerin Olduğu Hücre ==>A-B-C-D-E-F-H-K-L-O-R-S-V-BG

Aktarılması Gereken Hücre==>A-B-C-D-E-F-G-H-I-J-K-L-M-N

Saygılarımla
 

Ekli dosyalar

Merhaba,
...

Kod: 
Option Explicit
Sub deneme()
Dim b() As Variant, s1 As Worksheet, s2 As Worksheet
Dim sat As Long, i As Long, son As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("boşlar")
Application.ScreenUpdating = False
son = s1.Range("A" & Rows.Count).End(3).Row
On Error Resume Next

Erase b()
For i = 2 To son
    If s1.Cells(i, "O").Value = "Spot" And s1.Cells(i, "BG") = "0" [COLOR="Red"]Or _
       s1.Cells(i, "O").Value = "Spot" And s1.Cells(i, "BG") = ""[/COLOR] Then
        sat = sat + 1
       ' A -b - C - d - E - F - H - K - L - O - r - S - V - BG
    ReDim Preserve b(1 To 14, 1 To sat)
        b(1, sat) = s1.Range("A" & i).Value
        b(2, sat) = s1.Range("B" & i).Value
        b(3, sat) = s1.Range("C" & i).Value
        b(4, sat) = s1.Range("D" & i).Value
        b(5, sat) = s1.Range("E" & i).Value
        b(6, sat) = s1.Range("F" & i).Value
        b(7, sat) = s1.Range("H" & i).Value
        b(8, sat) = s1.Range("K" & i).Value
        b(9, sat) = s1.Range("L" & i).Value
        b(10, sat) = s1.Range("O" & i).Value
        b(11, sat) = s1.Range("R" & i).Value
        b(12, sat) = s1.Range("S" & i).Value
        b(13, sat) = s1.Range("V" & i).Value
        b(14, sat) = s1.Range("BG" & i).Value
    End If
Next i

s2.Range("A2:N65500").ClearContents
s2.Range("A2").Resize(sat, 14) = Application.Transpose(b)
Application.ScreenUpdating = True
MsgBox "İşlem tamam."
End Sub
 
Son düzenleme:
Aşağıdaki formülü deneyin
ekteki dosyayı inceleyin.
Kod: 
=EĞER(Sayfa1!$O2="Spot";EĞER(Sayfa1!$BG2="";Sayfa1!A2;"");"")

Kendi dosyanızda boş hücre sonucu "0" olarak gözüküyor ise;
Formülü yazdığınız hücreleri seçin Hücre Biçimlendirme / İsteğe uyarlanmıştan Tür bölümüne,
Kod: 
[=0]"";#.##0,00 $
yazın.
 

Ekli dosyalar

tasmed' Alıntı:
Merhaba,
...

Kod: 
Option Explicit
Sub deneme()
Dim b() As Variant, s1 As Worksheet, s2 As Worksheet
Dim sat As Long, i As Long, son As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("boşlar")
Application.ScreenUpdating = False
son = s1.Range("A" & Rows.Count).End(3).Row
On Error Resume Next

Erase b()
For i = 2 To son
    If s1.Cells(i, "O").Value = "Spot" And s1.Cells(i, "BG") = "" Then
        sat = sat + 1
       ' A -b - C - d - E - F - H - K - L - O - r - S - V - BG
    ReDim Preserve b(1 To 14, 1 To sat)
        b(1, sat) = s1.Range("A" & i).Value
        b(2, sat) = s1.Range("B" & i).Value
        b(3, sat) = s1.Range("C" & i).Value
        b(4, sat) = s1.Range("D" & i).Value
        b(5, sat) = s1.Range("E" & i).Value
        b(6, sat) = s1.Range("F" & i).Value
        b(7, sat) = s1.Range("H" & i).Value
        b(8, sat) = s1.Range("K" & i).Value
        b(9, sat) = s1.Range("L" & i).Value
        b(10, sat) = s1.Range("O" & i).Value
        b(11, sat) = s1.Range("R" & i).Value
        b(12, sat) = s1.Range("S" & i).Value
        b(13, sat) = s1.Range("V" & i).Value
        b(14, sat) = s1.Range("BG" & i).Value
    End If
Next i

s2.Range("A2:D65500").ClearContents
s2.Range("A2").Resize(sat, 14) = Application.Transpose(b)
Application.ScreenUpdating = True
MsgBox "İşlem tamam."
End Sub
Genişletmek için tıkla ...

Sayın Tasmed ilginiz için teşekkürler kodu kendi dosyamda uyguladığımda (Her hangi bir değişiklik yapmadan) spot haricindeki verileri de aktardı,

Eğer O sütunundaki değer spotsa ve BG de hücre 0 ya da boşsa işlem yapmalı spot harici hiçbir değerde işlem yapmamalı,

Saygılarımla ,

Teşekkürler,
 
Kodu güncelledim. Tekrar denermisiniz.
 
Merhaba
Alternatif olsun
Kod: 
Sub numan()
Dim s1 As Worksheet, s2 As Worksheet
Dim x As Long, son As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("boşlar")
s2.Range("A2:N" & Rows.Count).ClearContents
Application.ScreenUpdating = False
son = s1.Range("A" & Rows.Count).End(3).Row
satır = 2
For x = 2 To son
    If s1.Cells(x, "O").Value = "Spot" And s1.Cells(x, "BG") = 0 Or s1.Cells(x, "BG") = "" Then
        s2.Range("A" & satır).Value = s1.Range("A" & x).Value
        s2.Range("B" & satır).Value = s1.Range("B" & x).Value
        s2.Range("C" & satır).Value = s1.Range("C" & x).Value
        s2.Range("D" & satır).Value = s1.Range("D" & x).Value
        s2.Range("E" & satır).Value = s1.Range("E" & x).Value
        s2.Range("F" & satır).Value = s1.Range("F" & x).Value
        s2.Range("G" & satır).Value = s1.Range("H" & x).Value
        s2.Range("H" & satır).Value = s1.Range("K" & x).Value
        s2.Range("I" & satır).Value = s1.Range("L" & x).Value
        s2.Range("J" & satır).Value = s1.Range("O" & x).Value
        s2.Range("K" & satır).Value = s1.Range("R" & x).Value
        s2.Range("L" & satır).Value = s1.Range("S" & x).Value
        s2.Range("M" & satır).Value = s1.Range("V" & x).Value
        s2.Range("N" & satır).Value = s1.Range("BG" & x).Value
    satır = satır + 1
    End If
Next x
Application.ScreenUpdating = True
MsgBox "İşlem tamam."
End Sub
 
numan şamil' Alıntı:
Merhaba
Alternatif olsun
Kod: 
Sub numan()
Dim s1 As Worksheet, s2 As Worksheet
Dim x As Long, son As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("boşlar")
s2.Range("A2:N" & Rows.Count).ClearContents
Application.ScreenUpdating = False
son = s1.Range("A" & Rows.Count).End(3).Row
satır = 2
For x = 2 To son
    If s1.Cells(x, "O").Value = "Spot" And s1.Cells(x, "BG") = 0 Or s1.Cells(x, "BG") = "" Then
        s2.Range("A" & satır).Value = s1.Range("A" & x).Value
        s2.Range("B" & satır).Value = s1.Range("B" & x).Value
        s2.Range("C" & satır).Value = s1.Range("C" & x).Value
        s2.Range("D" & satır).Value = s1.Range("D" & x).Value
        s2.Range("E" & satır).Value = s1.Range("E" & x).Value
        s2.Range("F" & satır).Value = s1.Range("F" & x).Value
        s2.Range("G" & satır).Value = s1.Range("H" & x).Value
        s2.Range("H" & satır).Value = s1.Range("K" & x).Value
        s2.Range("I" & satır).Value = s1.Range("L" & x).Value
        s2.Range("J" & satır).Value = s1.Range("O" & x).Value
        s2.Range("K" & satır).Value = s1.Range("R" & x).Value
        s2.Range("L" & satır).Value = s1.Range("S" & x).Value
        s2.Range("M" & satır).Value = s1.Range("V" & x).Value
        s2.Range("N" & satır).Value = s1.Range("BG" & x).Value
    satır = satır + 1
    End If
Next x
Application.ScreenUpdating = True
MsgBox "İşlem tamam."
End Sub
Genişletmek için tıkla ...

Merhaba size de çok teşekkür ederim,
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst