• DİKKAT

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

StokListesi oluşturma

igultekin2000

igultekin2000

Katılım
5 Eylül 2007
Mesajlar
1,247
Excel Vers. ve Dili
ofis 2010
iyi günler; çeşitli işlemlerden sonra belli şekli getirdiğim listemi son haline getirmek istiyorum. Sayfa2' de oluşan listenin D ve E hücreleri aynı anda boş ise StokBakiye sayfasına aktarılmasın, şeklinde makroda
Kod: 
Sub sTok_Bakiye()
Set sl = Sheets("stokBakiye"): Set sk = Sheets("sayfa2")
son = sl.Range("A" & Rows.Count).End(3).Row + 2 'kopyalanacak sayfanın başlangıç satırı
sat = 2
sl.Range("a2:F" & son).ClearContents
For i = 2 To sk.Range("A" & Rows.Count).End(3).Row 'baz alınan sayfanın listelenecek ürün başlangıç satırı
If sk.Cells(i, "D") > 0 Then

sl.Cells(sat, "A") = sk.Cells(i, "A")
sl.Cells(sat, "B") = sk.Cells(i, "B")
sl.Cells(sat, "C") = sk.Cells(i, "C")
sl.Cells(sat, "D") = sk.Cells(i, "D")
sl.Cells(sat, "F") = sk.Cells(i, "F")
sat = sat + 1
End If
Next i
Sheets("stokBakiye").Select
Sheets("stokBakiye").Range("A2:F1000").Font.Name = "Calibri" 'yazı fontu
Sheets("stokBakiye").Select
Sheets("stokBakiye").Range("A2:f1000").Font.Size = 10 'yazı tipi boyutu
Sheets("StokBakiye").Select  ' konumlanma
Sheets("stokBakiye").Select
Range("c:f").NumberFormat = "#,##0.00"
End Sub

bu makroyu kullanmaya çalışıyorum " If sk.Cells(i, "D") > 0 Then " seçeneği ile en azından D sütunundaki boş hücreleri aktarmamayı denedim gene olmadı. benim asıl yapmak istediğin D ve E sütunu aynı anda boş ise o hücrelerin aktarılmaması. Teşekkürler
 

Ekli dosyalar

  • stokB.xlsm
    stokB.xlsm
    80.1 KB · Görüntüleme: 12
  • rESİM.jpg
    rESİM.jpg
    124.1 KB · Görüntüleme: 2
Merhaba
Kod: 
If sk.Cells(i, "D") = "" Or sk.Cells(i, "E") = ""Then
Olarak bir deneyin
 
Son düzenleme:
Sn.igultekin2000, aslında sizin kodlarınız düşündüğünüz doğrultuda doğru çalışıyor, Sayfa2 de boş gibi görünen d ve e sütunlarınızda boşluklar mevcut, bu boşlukları
Kod: 
Sub Dene()
    Cells.Replace Chr(160), ""
    For Each huc In ActiveSheet.UsedRange
        huc.Value = Trim(huc.Value)
    Next
End Sub
kodunu kullanarak silip, makronuzu çalıştırdığımda dediğiniz gibi sonuca gidiyor. Bilgilerinize
 
Son düzenleme:
Alternatif;

Boşluk ile ilgili açıklamayı sayın tahsinanarat yapmış.

Kod: 
Sub sTok_Bakiye()
Set sl = Sheets("stokBakiye"): Set sk = Sheets("sayfa2")
son = sl.Range("A" & Rows.Count).End(3).Row + 2 'kopyalanacak sayfanın başlangıç satırı
sat = 2
sl.Range("a2:F" & son).ClearContents
For i = 2 To sk.Range("A" & Rows.Count).End(3).Row 'baz alınan sayfanın listelenecek ürün başlangıç satırı
[COLOR=Red]If Val(sk.Cells(i, "D")) = 0 And Val(sk.Cells(i, "E")) = 0 Then

Else[/COLOR]
sl.Cells(sat, "A") = sk.Cells(i, "A")
sl.Cells(sat, "B") = sk.Cells(i, "B")
sl.Cells(sat, "C") = sk.Cells(i, "C")
sl.Cells(sat, "D") = sk.Cells(i, "D")
sl.Cells(sat, "F") = sk.Cells(i, "F")
sat = sat + 1
[COLOR=Red]End If[/COLOR]
Next i
Sheets("stokBakiye").Select
Sheets("stokBakiye").Range("A2:F1000").Font.Name = "Calibri" 'yazı fontu
Sheets("stokBakiye").Select
Sheets("stokBakiye").Range("A2:f1000").Font.Size = 10 'yazı tipi boyutu
Sheets("StokBakiye").Select  ' konumlanma
Sheets("stokBakiye").Select
Range("c:f").NumberFormat = "#,##0.00"
End Sub
 
Son düzenleme:
Sn. asri hocam
If Val(sk.Cells(i, "D")) = 0 And Val(sk.Cells(i, "D")) = 0 Then
satırınızı affınıza sığınarak
Kod: 
If Val(sk.Cells(i, "D")) = 0 And Val(sk.Cells(i, "E")) = 0 Then
Olmalıydı sanıyorum.

Sn.igultekin2000 bu durumda e sütununda dolu olanları görmeniz için kodlarınıza
Kod: 
sl.Cells(sat, "E") = sk.Cells(i, "E")
satırını da ilave etmelisiniz.
 
oluyor ama ufak bir sorun var.

tahsinanarat' Alıntı:
Sn.igultekin2000, aslında sizin kodlarınız düşündüğünüz doğrultuda doğru çalışıyor, Sayfa2 de boş gibi görünen d ve e sütunlarınızda boşluklar mevcut, bu boşlukları
Kod: 
Sub Dene()
    Cells.Replace Chr(160), ""
    For Each huc In ActiveSheet.UsedRange
        huc.Value = Trim(huc.Value)
    Next
End Sub
kodunu kullanarak silip, makronuzu çalıştırdığımda dediğiniz gibi sonuca gidiyor. Bilgilerinize
Genişletmek için tıkla ...
teşekkürler;
bu şekilde oluyor ama iki sayfadaki virgüllü sayıları metine dönüştürüp sola yaslıyor.
 
sn. igultekin2000 bu durumda kodlarınız sn. asri beyin kodlarıyla düzenlenmiş hali
Kod: 
Sub sTok_Bakiye()
Set sl = Sheets("stokBakiye"): Set sk = Sheets("sayfa2")
son = sl.Range("A" & Rows.Count).End(3).Row + 2 'kopyalanacak sayfanın başlangıç satırı
sat = 2
sl.Range("a2:F" & son).ClearContents
For i = 2 To sk.Range("A" & Rows.Count).End(3).Row 'baz alınan sayfanın listelenecek ürün başlangıç satırı
If Val(sk.Cells(i, "D")) = 0 And Val(sk.Cells(i, "e")) = 0 Then

Else
sl.Cells(sat, "A") = sk.Cells(i, "A")
sl.Cells(sat, "B") = sk.Cells(i, "B")
sl.Cells(sat, "C") = sk.Cells(i, "C")
sl.Cells(sat, "D") = sk.Cells(i, "D")
sl.Cells(sat, "E") = sk.Cells(i, "E")
sl.Cells(sat, "F") = sk.Cells(i, "F")
sat = sat + 1
End If
Next i
Sheets("stokBakiye").Select
Sheets("stokBakiye").Range("A2:F1000").Font.Name = "Calibri" 'yazı fontu
Sheets("stokBakiye").Select
Sheets("stokBakiye").Range("A2:f1000").Font.Size = 10 'yazı tipi boyutu
Sheets("StokBakiye").Select  ' konumlanma
Sheets("stokBakiye").Select
Range("c:f").NumberFormat = "#,##0.00"
End Sub

şeklindedir. Ben denedim çalışıyor.
 
Sn. igultekin2000 metin gibi görünenleri sayıya çevirmek için
Kod: 
Sub çevir()
Dim x As Range
For Each x In [C1:H500]
If x.Value <> "" Then
If IsNumeric(x.Value) = True Then
x.Value = x.Value * 1
'MsgBox x.Address
End If
End If
Next x
End Sub
kodunu kullanabilirsin.
 
teşekkürler

asri' Alıntı:
Alternatif;

Boşluk ile ilgili açıklamayı sayın tahsinanarat yapmış.

Kod: 
Sub sTok_Bakiye()
Set sl = Sheets("stokBakiye"): Set sk = Sheets("sayfa2")
son = sl.Range("A" & Rows.Count).End(3).Row + 2 'kopyalanacak sayfanın başlangıç satırı
sat = 2
sl.Range("a2:F" & son).ClearContents
For i = 2 To sk.Range("A" & Rows.Count).End(3).Row 'baz alınan sayfanın listelenecek ürün başlangıç satırı
[COLOR=Red]If Val(sk.Cells(i, "D")) = 0 And Val(sk.Cells(i, "D")) = 0 Then

Else[/COLOR]
sl.Cells(sat, "A") = sk.Cells(i, "A")
sl.Cells(sat, "B") = sk.Cells(i, "B")
sl.Cells(sat, "C") = sk.Cells(i, "C")
sl.Cells(sat, "D") = sk.Cells(i, "D")
sl.Cells(sat, "F") = sk.Cells(i, "F")
sat = sat + 1
[COLOR=Red]End If[/COLOR]
Next i
Sheets("stokBakiye").Select
Sheets("stokBakiye").Range("A2:F1000").Font.Name = "Calibri" 'yazı fontu
Sheets("stokBakiye").Select
Sheets("stokBakiye").Range("A2:f1000").Font.Size = 10 'yazı tipi boyutu
Sheets("StokBakiye").Select  ' konumlanma
Sheets("stokBakiye").Select
Range("c:f").NumberFormat = "#,##0.00"
End Sub
Genişletmek için tıkla ...
kod sorunsuz çalışıyor, teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst