satırlara düşeyara makrosu

[jinken]

Sub kod_düşeyaraYUNUSUÇAR()
Application.ScreenUpdating = False
Dim U As Long
Dim S1 As Worksheet
Dim SV As Worksheet
Set SV = Sheets("RAPOR")
Set S1 = Sheets("HAM ÜRÜNLER")

On Error Resume Next
S1.Range("K4:K65536").ClearContents
For U = 2 To S1.[H65536].End(3).Row
If S1.Cells(U, "H") <> "" Then

If WorksheetFunction.CountIf(SV.Range("A:A"), S1.Cells(U, "H")) > 0 Then ' EĞERSAY
' SAĞDAKİ
S1.Cells(U, "K") = WorksheetFunction.VLookup(S1.Cells(U, "H"), SV.Range("A:X"), 2, 0)
Else
S1.Cells(U, "K") = "0"
End If

Else
End If

Next U
Application.ScreenUpdating = True
MsgBox " Yunus UÇAR "
End Sub

 

[jinken]

Sub kod_düşeyaraYUNUSUÇAR()
Application.ScreenUpdating = False
Dim U As Long
Dim S1 As Worksheet
Dim SV As Worksheet
Set SV = Sheets("RAPOR")
Set S1 = Sheets("HAM ÜRÜNLER")

On Error Resume Next
S1.Range("K4:K65536").ClearContents
For U = 2 To S1.[H65536].End(3).Row
If S1.Cells(U, "H") <> "" Then

If WorksheetFunction.CountIf(SV.Range("A:A"), S1.Cells(U, "H")) > 0 Then ' EĞERSAY
' SAĞDAKİ
S1.Cells(U, "K") = WorksheetFunction.VLookup(S1.Cells(U, "H"), SV.Range("A:X"), 2, 0)
Else
S1.Cells(U, "K") = "0"
End If

Else
End If

Next U
Application.ScreenUpdating = True
MsgBox " Yunus UÇAR "
End Sub

 

[jinken]

arkadaşlar yukarıdaki kodu K4, L4, M4, N4....AG4' E kadar aramasını istiyorum.
S1.Cells(U, "K") = WorksheetFunction.VLookup(S1.Cells(U, "H"), SV.Range("A:X"), 2, 0)
S1.Cells(U, "K") = WorksheetFunction.VLookup(S1.Cells(U, "H"), SV.Range("A:X"), 3, 0)
S1.Cells(U, "K") = WorksheetFunction.VLookup(S1.Cells(U, "H"), SV.Range("A:X"), 4, 0)
a:x 24' e kadar arayacak
dosyada ekledim yardım edermisiniz.

 

[Emir Hüseyin Çoban]

. . .

Yazmışsınız zaten kodları, S1.Cells(U, "K") larda sütunlara göre artarak gitmeli.
İnceleyiniz.

S1.Cells(U, "K") = WorksheetFunction.VLookup(S1.Cells(U, "H"), SV.Range("A:X"), 2, 0)
S1.Cells(U, "L") = WorksheetFunction.VLookup(S1.Cells(U, "H"), SV.Range("A:X"), 3, 0)
S1.Cells(U, "M") = WorksheetFunction.VLookup(S1.Cells(U, "H"), SV.Range("A:X"), 4, 0)
S1.Cells(U, "N") = WorksheetFunction.VLookup(S1.Cells(U, "H"), SV.Range("A:X"), 5, 0)
S1.Cells(U, "O") = WorksheetFunction.VLookup(S1.Cells(U, "H"), SV.Range("A:X"), 6, 0)
S1.Cells(U, "P") = WorksheetFunction.VLookup(S1.Cells(U, "H"), SV.Range("A:X"), 7, 0)

Else
S1.Cells(U, "K") = "0"
S1.Cells(U, "L") = "0"
S1.Cells(U, "M") = "0"
S1.Cells(U, "N") = "0"
S1.Cells(U, "O") = "0"
S1.Cells(U, "P") = "0"

. . .

 

[jinken]

teşekkür ederim. farkında olmadan bende yazmışım