• DİKKAT

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

Fatura bilgisi saklayan VBA kodunu kurgulayamıyorum.

X

xlance

Katılım
18 Haziran 2011
Mesajlar
11
Excel Vers. ve Dili
Excel 2010 ingilizce
Merhaba arkadaşlar,

Birkaç gündür bununla uğraşıyorum kendim yapmaya çalıştım ama VBA hakkında çok bilgim yok ilgilenirseniz çok sevinirim.

Yapmaya çalıştığım şey şu; bir fatura sheet i var burda kullanıcı istediği ürünleri seçip müşteri bilgilerini giriyor daha sonra macro nun bu bilgileri örnekte gösterilen şekilde invoice data sheet ine taşıması lazım.

Bir türlü kurgulayamadım ama muhtemelen for each value in product codes column değerleri invoice data daki en son satıra kopyala gibi bir şeyler olması lazım ama tam olarak bilemiyorum :)

Örnek dosyada hem fatura nın hem fatura bilgilerinin saklandığı sayfanın örnek halini oluşturdum macronun data yı diğer sayfaya ne şekilde atması gerektiğini de ordan görebilirsiniz zaman ayırdığınız için şimdiden teşekkür ederim.

Question.xlsm
 
Tekrar Merhaba

Herkese Merhaba,

Sizden cevap beklerken kodu kendim oluşturmaya çalıştım ve şöyle bir şey çıktı örnek dosyayı da ekledim Ürün kodu istediğim şekilde taşınıyor çünkü onu zaten for each kısmında tanımlamış oluyorum ancak sıra no, adet ve birim toplamı kolonlarını doğru şekilde getirmeyi başaramadım zaten boş bıraktım o kısımları.

Yardımlarınızı bekliyorum,

Kod: 
Option Explicit
Sub StoreInvoice()

Dim ProductCode As Range
Dim LineNo As Range
Dim Quantity As Range
Dim UnitTotal As Range
Dim InvoiceData As Worksheet
Dim Invoice As Worksheet
Dim LastRow As Long

Set Invoice = Sheets("Invoice")
Set InvoiceData = Sheets("Invoice Data")

For Each ProductCode In Invoice.Range("B14:B33")

LastRow = InvoiceData.Cells(65536, 1).End(3).Row + 1

If ProductCode.Value <> "" Then
    InvoiceData.Cells(LastRow, "a") = Invoice.Range("e1") 'Invoice No
    InvoiceData.Cells(LastRow, "b") = Invoice.Range("b7") 'Date
    'Line No InvoiceData.Cells(LastRow, "c") =
    InvoiceData.Cells(LastRow, "d") = ProductCode 'Product Code
    'Quantity InvoiceData.Cells(LastRow, "e") =
    'UnitTotal InvoiceData.Cells(LastRow, "f") =
    InvoiceData.Cells(LastRow, "g") = Invoice.Range("b1") 'Name
    InvoiceData.Cells(LastRow, "h") = Invoice.Range("b2") 'Address
    InvoiceData.Cells(LastRow, "i") = Invoice.Range("b3") 'Region
    InvoiceData.Cells(LastRow, "j") = Invoice.Range("b4") 'City
    InvoiceData.Cells(LastRow, "k") = Invoice.Range("b5") 'Rep
    InvoiceData.Cells(LastRow, "l") = Invoice.Range("b6") 'Cellphone
    InvoiceData.Cells(LastRow, "m") = Invoice.Range("b8") 'Time
    InvoiceData.Cells(LastRow, "n") = Invoice.Range("e2") 'ID No:
    InvoiceData.Cells(LastRow, "o") = Invoice.Range("e3") 'Delivery Address
End If
Next

InvoiceData.Activate

End Sub
 

Ekli dosyalar

Merhaba,

Bu şekilde deneyin.

Kod: 
Sub Kaydet()
 
    Dim Sd As Worksheet, son As Long, i As Long
 
    Application.ScreenUpdating = False
    Sheets("Invoice").Select
 
    Set Sd = Sheets("Invoice Data")
    son = Sd.Cells(Rows.Count, "A").End(xlUp).Row + 1
 
    For i = 14 To Cells(Rows.Count, "B").End(xlUp).Row
        If Cells(i, "B") <> "" Then
            Sd.Cells(son, "A") = Range("E1")
            Sd.Cells(son, "B") = Format(Range("B7"), "dd.mm.yyyy")
            Sd.Cells(son, "C") = Cells(i, "A")
            Sd.Cells(son, "D") = Cells(i, "B")
            Sd.Cells(son, "E") = Cells(i, "D")
            Sd.Cells(son, "F") = Cells(i, "F")
            Range("B1:B6").Copy
            Sd.Cells(son, "G").PasteSpecial Transpose:=True
            Sd.Cells(son, "M") = Format(Range("B8"), "hh:mm")
            Sd.Cells(son, "N") = Range("E2")
            Sd.Cells(son, "O") = Range("E3")
            son = son + 1
        End If
        Application.CutCopyMode = False
    Next i
 
    Sd.Select: Range("A1").Select
    Application.ScreenUpdating = True
 
End Sub

.
 
Merhaba Ömer Bey,

Forumdan cevap beklemeye devam ederken ben şu şekilde bi kod yazıp olayı çözdüm sanırım :)

Sizin kodunuzu da denedim aynı sonucu veriyor gerçekten çok teşekkür ederim elinize sağlık. Benim yazdığım da şu şekilde bir değerlendirip fikrinizi söylerseniz çok sevinirim. Sonuç aynı ama en iyi pratikleri uygulama açısından burda bir yanlış var mı?

Kod: 
Option Explicit
Sub StoreInvoice()

Dim ProductCode As Variant
Dim LineNo As Variant
Dim Quantity As Variant
Dim UnitTotal As Variant
Dim InvoiceData As Worksheet
Dim Invoice As Worksheet
Dim LastRow As Long
Dim i As Integer

Set Invoice = Sheets("Invoice")
Set InvoiceData = Sheets("Invoice Data")


For i = 14 To 33

LineNo = Invoice.Cells(i, 1).Value
ProductCode = Invoice.Cells(i, 2).Value
Quantity = Invoice.Cells(i, 4).Value
UnitTotal = Invoice.Cells(i, 6).Value

LastRow = InvoiceData.Cells(65536, 1).End(3).Row + 1

If ProductCode <> "" Then
    InvoiceData.Cells(LastRow, "a") = Invoice.Range("e1") 'Invoice No
    InvoiceData.Cells(LastRow, "b") = Invoice.Range("b7") 'Date
    InvoiceData.Cells(LastRow, "c") = LineNo 'Line No
    InvoiceData.Cells(LastRow, "d") = ProductCode 'Product Code
    InvoiceData.Cells(LastRow, "e") = Quantity 'Quantity
    InvoiceData.Cells(LastRow, "f") = UnitTotal 'UnitTotal
    InvoiceData.Cells(LastRow, "g") = Invoice.Range("b1") 'Name
    InvoiceData.Cells(LastRow, "h") = Invoice.Range("b2") 'Address
    InvoiceData.Cells(LastRow, "i") = Invoice.Range("b3") 'Region
    InvoiceData.Cells(LastRow, "j") = Invoice.Range("b4") 'City
    InvoiceData.Cells(LastRow, "k") = Invoice.Range("b5") 'Rep
    InvoiceData.Cells(LastRow, "l") = Invoice.Range("b6") 'Cellphone
    InvoiceData.Cells(LastRow, "m") = Invoice.Range("b8") 'Time
    InvoiceData.Cells(LastRow, "n") = Invoice.Range("e2") 'ID No:
    InvoiceData.Cells(LastRow, "o") = Invoice.Range("e3") 'Delivery Address
End If

Next i

InvoiceData.Activate

End Sub


Ömer' Alıntı:
Merhaba,

Bu şekilde deneyin.

Kod: 
Sub Kaydet()
 
    Dim Sd As Worksheet, son As Long, i As Long
 
    Application.ScreenUpdating = False
    Sheets("Invoice").Select
 
    Set Sd = Sheets("Invoice Data")
    son = Sd.Cells(Rows.Count, "A").End(xlUp).Row + 1
 
    For i = 14 To Cells(Rows.Count, "B").End(xlUp).Row
        If Cells(i, "B") <> "" Then
            Sd.Cells(son, "A") = Range("E1")
            Sd.Cells(son, "B") = Format(Range("B7"), "dd.mm.yyyy")
            Sd.Cells(son, "C") = Cells(i, "A")
            Sd.Cells(son, "D") = Cells(i, "B")
            Sd.Cells(son, "E") = Cells(i, "D")
            Sd.Cells(son, "F") = Cells(i, "F")
            Range("B1:B6").Copy
            Sd.Cells(son, "G").PasteSpecial Transpose:=True
            Sd.Cells(son, "M") = Format(Range("B8"), "hh:mm")
            Sd.Cells(son, "N") = Range("E2")
            Sd.Cells(son, "O") = Range("E3")
            son = son + 1
        End If
        Application.CutCopyMode = False
    Next i
 
    Sd.Select: Range("A1").Select
    Application.ScreenUpdating = True
 
End Sub

.
Genişletmek için tıkla ...
 
Mantık aynı. Tercih sizin, ileride değişiklik yaparken kendi yazdığınızı daha kolay çözeceğinizden, kendi yazdıklarınızı kullanmanız daha mantıklı olur diye düşünüyorum.

Yalnız,

For i = 14 To 33


Buradaki 33 değeri yerine B sütunundaki son satırı bulup döngüye o şekilde sokarsanız gereksiz yere işlemi uzatmamış olursunuz.

.
 
Evet Ömer Bey sizin yazdığınız kodu incelerken o kısmı farkettim çok akıllıca gerçekten ama mesela kullanıcı gidip B sütununda aşağıda kalan bir hücreye bir şey yazarsa macroyu bozar diye statik sayı girdim mesela yine saydırarak yaptırmak ancak 33 ten sonrasını saydırmamak mümkün olabilir mi?

Ömer' Alıntı:
Mantık aynı. Tercih sizin, ileride değişiklik yaparken kendi yazdığınızı daha kolay çözeceğinizden, kendi yazdıklarınızı kullanmanız daha mantıklı olur diye düşünüyorum.

Yalnız,

For i = 14 To 33


Buradaki 33 değeri yerine B sütunundaki son satırı bulup döngüye o şekilde sokarsanız gereksiz yere işlemi uzatmamış olursunuz.

.
Genişletmek için tıkla ...
 
Bu şekilde deneyin.

Kod: 
For i = 14 To Cells([COLOR=red]34[/COLOR], "B").End(xlUp).Row

.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst