Aranan ddeğerin satırını öğrenme

[atillaciftci]

Aşağıdaki kod Kaydet düğmesine bastığımda kaydetmesi gereken dosyayı açıyor ve d16:d65536 aralığına bakıyor TextBox9 da yazan şey bu aralıkda yazıyorsa var diye uyarı veriyor yoksa devam ediyor..

Uyarı verdi ise uyarı verdiği TextBox9 metni hangi satırda ise o satırın D ile Q hücresi aralığına MALIYET ANALIZI.xls dosyasının J25:W25 satırındakileri yazsın istiyorum..



Private Sub CommandButton1_Click()
Dim i As Integer

TextBox23.Value = ComboBox1.Value

Workbooks.Open ("\\Bsserver\Repair\ISLETME\Taşeron\Taşeron Performans\Taşerona Göre\2012\Atilla Deneme\" & TextBox23.Value & ".xls")
If WorksheetFunction.CountIf(Sheets("per").Range("d16:d65536"), TextBox9) > 0 Then

Workbooks(TextBox23.Value & ".xls").Close

i = Range("B75").End(xlUp).Offset(1, 0).Row ' Aşağıdan başlayarak A sütununda en son dolu satırın altındaki boş hücre
Rows(i).Delete Shift:=xlUp
MsgBox "Önceden bu Taşeronu bu Gemi için değerlendirmişsiniz...", , "UYARI"
End ' UserForm u kapatır

Exit Sub
Else
On Error Resume Next

Workbooks("MALIYET ANALIZI.xls").Activate
Sheets("Toplam").Range("j100").End(xlUp).Offset(1, 0).Value = TextBox9.Value
Sheets("Toplam").Range("L100").End(xlUp).Offset(1, 0).Value = TextBox10.Value
Sheets("Toplam").Range("M100").End(xlUp).Offset(1, 0).Value = TextBox11.Value
Sheets("Toplam").Range("N100").End(xlUp).Offset(1, 0).Value = TextBox12.Value
Sheets("Toplam").Range("O100").End(xlUp).Offset(1, 0).Value = TextBox13.Value
Sheets("Toplam").Range("P100").End(xlUp).Offset(1, 0).Value = TextBox14.Value
Sheets("Toplam").Range("Q100").End(xlUp).Offset(1, 0).Value = TextBox15.Value
Sheets("Toplam").Range("R100").End(xlUp).Offset(1, 0).Value = TextBox16.Value
Sheets("Toplam").Range("S100").End(xlUp).Offset(1, 0).Value = TextBox17.Value
Sheets("Toplam").Range("T100").End(xlUp).Offset(1, 0).Value = TextBox18.Value
Sheets("Toplam").Range("U100").End(xlUp).Offset(1, 0).Value = TextBox19.Value
Sheets("Toplam").Range("V100").End(xlUp).Offset(1, 0).Value = TextBox20.Value
Sheets("Toplam").Range("W100").End(xlUp).Offset(1, 0).Value = TextBox21.Value

Sheets("Toplam").Range("J25:W25").Select
Selection.Copy

Windows(TextBox23.Value & ".xls").Activate
Sheets("per").Range("D100").End(xlUp).Offset(1, 0).Select ' Aşağıdan başlayarak A sütununda en son dolu satırın altındaki boş hücre
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("per").Range("D100").End(xlUp).Offset(1, 0).Select ' Aşağıdan başlayarak A sütununda en son dolu satırın altındaki boş hücre

Windows("MALIYET ANALIZI.xls").Activate
Application.CutCopyMode = False
ActiveWindow.SmallScroll ToRight:=-5
Range("B25").Select

Windows(TextBox23.Value & ".xls").Activate

'Üst hücreyi alta kopyalar (ctrl+d)
Sheets("per").Range("R75").End(xlUp).Offset(1, 0).Select ' Aşağıdan başlayarak A sütununda en son dolu satırın altındaki boş hücre
Selection.FillDown

Sheets("per").Range("S75").End(xlUp).Offset(1, 0).Select ' Aşağıdan başlayarak A sütununda en son dolu satırın altındaki boş hücre
Selection.FillDown

Workbooks("MALIYET ANALIZI.xls").Activate
Sheets("Toplam").Range("b75").End(xlUp).Offset(1, 0).Value = TextBox23.Value

Application.CutCopyMode = False

End
ActiveWorkbook.Close True
End If
End Sub

 

[baydeniro]

Sayın atillaciftci. Böylesine komplike bir işlemi örnek dosya eklemeden size yardımcı olunaibileceğini beklemiyorsunuz herhalde !!

 

[atillaciftci]

Aslında bekliyordum Hemen örnek dosya ekleyecem ozaman