satırda soldan sağa doğru ilerleme

[nikomedian]

Arattığım kelimeyi bulduğunda, soldan sağa doğru tek tek ilerleyerek kopyalayıp, tanımladığım bir kelimeyi okuyunca durak vba kodu arıyorum.

Örneğin; A sütununda arama yapacak, Ğ harfini bulunca Ç harfine kadar olan kısmı kopyalayacak. yardımlarınızı bekliyorum.

A B C D E F G
1 O P K J L P B
2 H J K U C S E
3 Ğ K L N B C Ç

 

[Orion1]

dosya ekte.

Sub kopayala()
Dim deg
deg = InputBox("Kelimeyi Girin :", "KELİME ARA KOPYALA", "Ğ")
If deg = Empty Then Exit Sub
Set k = Range("A1:A65536").Find(deg, , xlValues, xlWhole)
If Not k Is Nothing Then
    Range(Cells(k.Row, "A"), Cells(k.Row, "G")).Copy Range("H1")
End If
End Sub

 

[nikomedian]

çok sağolun hemen inceliyorum.

 

[nikomedian]

sheet2'de ÜRÜN yazısın sağındakileri, sheet1'de sevk tarinin altındaki satıra yazdırmak istiyorum ama sürekli hata veriyor, yanlışım nerede ?

Sub DENE()
Dim i, slu, slr, slf, k, tmp, tmb, m, l, b As Integer
Dim r As Boolean
Dim harf(28)
harf(1) = "A"
harf(2) = "B"
harf(3) = "C"
harf(4) = "D"
harf(5) = "E"
harf(6) = "F"
harf(7) = "G"
harf(8) = "H"
harf(9) = "I"
harf(10) = "J"
harf(11) = "K"
harf(12) = "L"
harf(13) = "M"
harf(14) = "N"
harf(15) = "O"
harf(16) = "P"
harf(17) = "Q"
harf(18) = "R"
harf(19) = "S"
harf(20) = "T"
harf(21) = "U"
harf(22) = "V"
harf(23) = "W"
harf(24) = "Y"
harf(25) = "Z"
harf(26) = "AA"
harf(27) = "AB"
harf(28) = "AC"
Sheets("Sheet2").Select
slu = 1
For i = 1 To 7000
Range("A" & i).Select
Select Case ActiveCell.Value
Case "ÜRÜN:"
Range("G" & i).Select
Selection.Copy
Selection.Copy Destination:=Sheets("Sheet1").Range("B" & slu)
slr = slu + 3
slf = slu + 2

Sheets("Sheet2").Select
Range("B" & i).Select
Selection.Copy
Selection.Copy Destination:=Sheets("Sheet1").Range("L" & slu)

slu = slu + 17

Sheets("Sheet2").Select
Range("O" & i).Select
Selection.Copy
Selection.Copy Destination:=Sheets("Sheet1").Range("L" & slf)

Sheets("Sheet2").Select
Range("A" & i).Select
Case "Renk"
tmp = slr
tmb = slr
k = i + 1
m = 2
l = i
b = 2

Do While Cells(k, 1) <> "TOPLAM"
Sheets("Sheet1").Cells(tmp, 1) = Range("A" & k).Value

tmp = tmp + 1
k = k + 1
Loop

Do While Cells(m, l) <> "TOPLAM"
Sheets("Sheet1").Cells(harf(b) & tmb) = Range(harf(m) & l).Value

b = b + 1
m = m + 1

Loop

End Select
Next i
End Sub