Tablo dan (Fişten) Sayfa 2 ye Veri Aktarımı

[senuyurken]

Merhaba arkadaşlar; Örnek dosyamı ekliyorum. Sizlerden Sayfa 1 e girmiş olduğum verileri Firma bazında ve fişteki kalemler bazında sayfa 2 ye ilgili yere sıralı bir şekilde aktarılmasını rica ediyorum. Her yeni fiş girdiğimde sayfa 2 nin de güncellenmesini istiyorum. Bu işlemler günlük yapılmaktadır.

Şimdiden yardımlarınız için çok ama çok teşekkür ederim.

 

[catalinastrap]

Merhaba dosyanız ektedir

 

[senuyurken]

Merhaba dosyanız ektedir

Günaydın arkadaşım. Çok Çok Teşekkür ederim.

 

[senuyurken]

İyi Akşamlar arkadaşım. Dosyayı bu gün büyük bir zevkle kullandım. Ellerine sağlık.

Fakat şöyle bir sorunla karşılaştım. Yetkili kısmıda aktarırsa çok memnun olacağım. Gün sonu ayırmakta çok zorluk çektim.

Aynı firmadan değişik yetkililer gelmektedeir.

Çok Çok Teşekkür ederim.

 

[catalinastrap]

Sub SatirBazliGetir()
Dim ws1 As Worksheet
Dim ws3 As Worksheet
Dim lastRow1 As Long
Dim lastRow3 As Long
Dim i As Long
Dim firmaIsmi As String
Dim yetkili As String


Set ws1 = ThisWorkbook.Sheets("sayfa1")
Set ws3 = ThisWorkbook.Sheets("sayfa3")

lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row

firmaIsmi = ws1.Range("C4").Value
yetkili = ws1.Range("C5").Value


ws1.Range("G3").Value = ws1.Range("G3").Value + 1

lastRow3 = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row
If lastRow3 = 1 And ws3.Cells(1, 1).Value = "" Then

ws3.Range("A1").Value = "YETKİLİ"
ws3.Range("B1").Value = "FIRMA"
ws3.Range("C1").Value = "HAVA"
ws3.Range("D1").Value = "SU"
ws3.Range("E1").Value = "ATEŞ"
ws3.Range("F1").Value = "OKSİJEN"
lastRow3 = 2
Else
lastRow3 = lastRow3 + 1
End If


Dim havaRow As Long, suRow As Long, atesRow As Long, oksijenRow As Long
havaRow = lastRow3
suRow = lastRow3
atesRow = lastRow3
oksijenRow = lastRow3

For i = 1 To lastRow1

Select Case ws1.Cells(i, 3).Value
Case "HAVA"
ws3.Cells(havaRow, 1).Value = yetkili
ws3.Cells(havaRow, 2).Value = firmaIsmi
ws3.Cells(havaRow, 3).Value = ws1.Cells(i, 2).Value
havaRow = havaRow + 1
Case "SU"
ws3.Cells(havaRow, 1).Value = yetkili
ws3.Cells(havaRow, 2).Value = firmaIsmi
ws3.Cells(suRow, 4).Value = ws1.Cells(i, 2).Value
suRow = suRow + 1
Case "ATEŞ"
ws3.Cells(havaRow, 1).Value = yetkili
ws3.Cells(havaRow, 2).Value = firmaIsmi
ws3.Cells(atesRow, 5).Value = ws1.Cells(i, 2).Value
atesRow = atesRow + 1
Case "OKSİJEN"
ws3.Cells(havaRow, 1).Value = yetkili
ws3.Cells(havaRow, 2).Value = firmaIsmi
ws3.Cells(oksijenRow, 6).Value = ws1.Cells(i, 2).Value
oksijenRow = oksijenRow + 1
End Select


Select Case ws1.Cells(i, 7).Value
Case "HAVA"
ws3.Cells(havaRow, 1).Value = yetkili
ws3.Cells(havaRow, 2).Value = firmaIsmi
ws3.Cells(havaRow, 3).Value = ws1.Cells(i, 6).Value
havaRow = havaRow + 1
Case "SU"
ws3.Cells(havaRow, 1).Value = yetkili
ws3.Cells(havaRow, 2).Value = firmaIsmi
ws3.Cells(suRow, 4).Value = ws1.Cells(i, 6).Value
suRow = suRow + 1
Case "ATEŞ"
ws3.Cells(havaRow, 1).Value = yetkili
ws3.Cells(havaRow, 2).Value = firmaIsmi
ws3.Cells(atesRow, 5).Value = ws1.Cells(i, 6).Value
atesRow = atesRow + 1
Case "OKSİJEN"
ws3.Cells(havaRow, 1).Value = yetkili
ws3.Cells(havaRow, 2).Value = firmaIsmi

ws3.Cells(oksijenRow, 6).Value = ws1.Cells(i, 6).Value
oksijenRow = oksijenRow + 1
End Select
Next i



MsgBox "İşlem tamamlandı ve sonuçlar satır bazlı olarak sayfa3'e yazıldı."


End Sub

 

[catalinastrap]

Dosya olarak ta ekliyorum

 

[senuyurken]

Çok Çok Teşekkür ederim @catalinastrap