Aktarma, otomatik kod verme

[serdenm]

Herkese iyi bayramlar dilerim,

Ekteki dosyada detay mevcuttur. Ozet olarak:

1. ana giris sayfasinda veri girildikten sonra ilgili tipe (type) gore verinin kopyalanmasi.

2. kopyalanam satirdaki veriye yine tipine gore kod olusturulmasi.

simdiden cok tesekkur ederim.

 

[AS3434]

Sayın serdenm

Ekli dosyayı inceleyin. İstediğiniz böyle birşey mi?

 

[AS3434]

Selam
Kodlarda bir hata yapmışım,daha doğrusu sıra no verirken ilk verilerde sorun oluyor.

Kodları şöyle değiştirin. (Mavi kısım değişik)

Sub Makro1()
a = Sheets.Count
For i = 2 To a
  For x = 2 To [a65536].End(3).Row
If Sheets(i).Name = Sayfa1.Cells(x, 1) Then
z = Sheets(i).[a65536].End(3).Row + 1
Sheets(i).Cells(z, 1) = Sayfa1.Cells(x, 1)
[COLOR=blue]Sheets(i).Cells(z, 2) = WorksheetFunction.CountA(Sheets(i).Range("b2:b10000")) + 1[/COLOR]
Sheets(i).Cells(z, 3) = Sayfa1.Cells(x, 2)
Sheets(i).Cells(z, 4) = Sayfa1.Cells(x, 3)
Sheets(i).Cells(z, 5) = Sayfa1.Cells(x, 4)
Sheets(i).Cells(z, 6) = Sayfa1.Cells(x, 5)
End If
Next: Next
MsgBox ("Aktarma Tamamlandı")
End Sub

 

[N.Ziya Hiçdurmaz]

yanıt

Sub aktar()
For i = 2 To Sheets.Count
Set s1 = Sheets("giriş")
For sut = 2 To s1.[a65536].End(3).Row
If Sheets(i).Name = s1.Range("a" & sut).Value Then
s1.Range("a" & sut).Copy
s = Sheets(i).[a65536].End(3).Row
Sheets(i).Range("a" & s + 1).PasteSpecial Paste:=xlValues
s1.Range("b" & sut & ":e" & sut).Copy
ss = Sheets(i).[a65536].End(3).Row
Sheets(i).Range("c" & ss).PasteSpecial Paste:=xlValues
End If: Next: Next
End Sub

 

[serdenm]

AS3434 ve VBA,
ilginize cok tesekkur ederim.

Sayin AS3434 kodu inceledim. makroyu anlamak acisindan 2 sorum var.
1. Herhangi bir Tipi ilgili sheete nasil kopyaliyor? makroda bunu göremedim.

2. B sutunlarindaki 1,2,3 numaralandirma hangi komut satirinda oluyor?

cok tesekkuer ederim.

 

[AS3434]

sayın serdenm

İzah kabiliyetim fazla yoktur ama gerekli yerleri renklendirdim.

Sub Makro1()
a = Sheets.Count
For i = 2 To a
  For x = 2 To [a65536].End(3).Row
If Sheets(i).Name = Sayfa1.Cells(x, 1) Then '[COLOR=green]Sayfa adı ile hücredeki veri eşitliği kontrolu[/COLOR]
z = Sheets(i).[a65536].End(3).Row + 1 [COLOR=green]'Sayfaların ilk boş satırı[/COLOR]
[COLOR=red]Sheets(i).Cells(z, 1) = Sayfa1.Cells(x, 1)[/COLOR][COLOR=green]'TYPE[/COLOR]
[COLOR=blue]Sheets(i).Cells(z, 2) = WorksheetFunction.CountA(Sheets(i).Range("b2:b10000")) + 1  [/COLOR][COLOR=green]' sıra no[/COLOR]
[COLOR=red]Sheets(i).Cells(z, 3) = Sayfa1.Cells(x, 2) [/COLOR][COLOR=green]'Folder[/COLOR]
[COLOR=red]Sheets(i).Cells(z, 4) = Sayfa1.Cells(x, 3) [/COLOR][COLOR=green]'X[/COLOR]
[COLOR=red]Sheets(i).Cells(z, 5) = Sayfa1.Cells(x, 4) [/COLOR][COLOR=green]'Y[/COLOR]
[COLOR=red]Sheets(i).Cells(z, 6) = Sayfa1.Cells(x, 5)[/COLOR][COLOR=green] 'Z[/COLOR]
End If
Next: Next
MsgBox ("Aktarma Tamamlandı")
End Sub

Bu arada 1 gol attık.