İlk Boş Sütun hücrelerine textbox tan veri yazdırabilmek

[ex912]

Selamlar,
ektedeki dosyada daha ayrıntılı açıkladığım gibi amacım ilk boş Sütundan başlayarak combo box ya da text box tan verileri ilgili hücrelere yazdırabilmek. Mevcut makro kodu İlk tam boş satırı buluyor ve verileri alt alta satırlara yazdırabiliyor.

İlk boş satırı şu kod ile buluyorum.

lRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
lPart = Me.parttype.ListIndex

Belki benzer kod ile sütunları arayıp bir matris yapı oluşturarak hedef hücrelere list yada combo box'tan veri yazdırılabilir, fakat VBA tecrübem henüz buna yetmedi.

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

kullandığım kod:

Option Explicit

Private Sub CommandButton1_Click()
    Unload Me
End Sub
Private Sub UserForm_Initialize()
    Dim cPart As Range
    Dim cLoc As Range
    Dim ws As Worksheet
    Set ws = Worksheets("PartsInventory")
    
'Part Type
    For Each cLoc In ws.Range("Inventory")
     With Me.parttype
    .AddItem cLoc.Value
     End With
    Next cLoc
 End Sub

Private Sub PartAdd_Click()
Dim i As Integer
Dim final As Integer
Dim lRow As Long
Dim lPart As Long
Dim xlLastCol As Long
Dim ws As Worksheet
Set ws = Worksheets("PartsInventory")

'sıradaki ilk boş satırı arar

lRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
lPart = Me.parttype.ListIndex

' Combo box seçimine göre verileri ilgili satır hücrelerine yazdırır.

If Me.parttype.Value = "Reflector" Then

With ws
.Cells(lRow, 2).Value = Me.partnumber.Value
.Cells(lRow, 3).Value = Me.PartSupp.Value
.Cells(lRow, 4).Value = Me.PartSize.Value
.Cells(lRow, 5).Value = Me.txtdate.Value
End With

ElseIf Me.parttype.Value = "Diffuser" Then

With ws
.Cells(lRow, 7).Value = Me.partnumber.Value
.Cells(lRow, 8).Value = Me.PartSupp.Value
.Cells(lRow, 9).Value = Me.PartSize.Value
.Cells(lRow, 10).Value = Me.txtdate.Value
End With

ElseIf Me.parttype.Value = "Prism" Then
With ws
.Cells(lRow, 12).Value = Me.partnumber.Value
.Cells(lRow, 13).Value = Me.PartSupp.Value
.Cells(lRow, 14).Value = Me.PartSize.Value
.Cells(lRow, 15).Value = Me.txtdate.Value
End With

Else
MsgBox " Lütfen Envanter Tipini seçin "

End If
End Sub

 

[denemetor]

Ustten(1. satir) aramaya baslayip ilk bos satiri bulup, alttan (en alttaki satir) aramaya baslayip en son musait bos satiri da bulduktan sonra, bir IF ile bu iki satir degeri birbirine esit mi baktirirsaniz istediginiz olur eger ben yanlis anlamadiysam. Degerler esitse o satira yazdirirsiniz, degilse ustteki satira yazdirirsiniz.

 

[Orion1]

Doısyanız ektedir.

Private Sub PartAdd_Click()
Dim sat As Long, sut As Byte
sut = Me.parttype.ListIndex * 5 + 2
With Sheets("PartsInventory")
    sat = .Cells(Rows.Count, sut).End(xlUp).Row + 1
    .Cells(sat, sut).Value = Me.parttype.Value
    .Cells(sat, sut + 1).Value = Me.PartSupp.Value
    .Cells(sat, sut + 2).Value = CDbl(Me.PartSize.Value)
    .Cells(sat, sut + 3).Value = CDate(Me.txtdate.Value)
End With
MsgBox "Veriler aktarıldı." & vbLf & "evrengizlen@hotmail.com", _
vbOKOnly + vbInformation, Application.UserName
End Sub

 

[ex912]

Çok teşekkür ederim, yazdığınız kod ile sorun çözüldü.