rapolama yardım

[karakoc39]

merhabalar
aşağıdaki linkte excelim nevcut makine kodunu yazınca değerleri getirmesini istiyorum
düşeyara ile yaptım fakat bu taslakta olmuyor veri tabanını değiştirmem lazım oda univarsal olduğu için çok uzun ve meşakatli olacak
yardımlarınızı bekliyorum
sağlıklı günler dilerim

İndir rapor

Dosyayı indir rapor

dosya.co

 

[YUSUF44]

Aşağıdaki kodları KONTROL sayfasının kod bölümüne (sayfa adına sağ tıklayıp Kod Görüntüle deyince açılan sayfaya) kopyalayıp deneyin. Makine adını değiştirdiğinizde istediğiniz işlemi yapar, makineye ait bilgi yoksa hata verir ve tabloyu boşaltır:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A40]) Is Nothing Then Exit Sub
If Target = "" Then
    For i = 3 To 38 Step 5
        Range("C" & i & ":E" & i + 2).ClearContents
    Next
    Exit Sub
Else
    Set s1 = Sheets("SAYFA")
    son = s1.Cells(Rows.Count, "B").End(3).Row
    If WorksheetFunction.CountIf(s1.Range("B1:B" & son), Target) = 0 Then
        For i = 3 To 38 Step 5
            Range("C" & i & ":E" & i + 2).ClearContents
        Next
        MsgBox "Belirtilen makine bulunamadı", vbCritical
        Target.Select
        Exit Sub
    Else
        Application.ScreenUpdating = False
        sat = WorksheetFunction.Match(Target, s1.Range("B1:B" & son), 0)
        a = 3
        For j = 5 To 26 Step 3
            s1.Range(s1.Cells(sat, j), s1.Cells(sat + 2, j + 2)).Copy: Cells(a, "C").PasteSpecial Paste:=xlValues
            a = a + 5
        Next
        Application.CutCopyMode = False
        Target.Select
        Application.ScreenUpdating = True
    End If
End If
End Sub

 

[karakoc39]

Merhaba Yusuf bey
çok teşekkürler hemen deniyorum

 

[karakoc39]

Yusuf Bey
çok teşekkür ederim elinize sağlık tam istediğim gibi çalışıyor
sağlıklı günler dilerim

 

[karakoc39]

yusuf hocam bir sorum olacak
bu kod da makine kodunu yazmayinca hata veryor.
onun yerine bir mesaj yazılabilir mi.makine no yaziniz gibi
teşekkürler

 

[YUSUF44]

Nasıl bir hata veriyor?

 

[karakoc39]

 

[YUSUF44]

Aşağıdaki gibi deneyin:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A40]) Is Nothing Then Exit Sub
On Error GoTo 10:
If Target = "" Then
    For i = 3 To 38 Step 5
        Range("C" & i & ":E" & i + 2).ClearContents
    Next
    Exit Sub
Else
    Set s1 = Sheets("SAYFA")
    son = s1.Cells(Rows.Count, "B").End(3).Row
    If WorksheetFunction.CountIf(s1.Range("B1:B" & son), Target) = 0 Then
        For i = 3 To 38 Step 5
            Range("C" & i & ":E" & i + 2).ClearContents
        Next
        MsgBox "Belirtilen makine bulunamadı", vbCritical
        Target.Select
        Exit Sub
    Else
        Application.ScreenUpdating = False
        sat = WorksheetFunction.Match(Target, s1.Range("B1:B" & son), 0)
        a = 3
        For j = 5 To 26 Step 3
            s1.Range(s1.Cells(sat, j), s1.Cells(sat + 2, j + 2)).Copy: Cells(a, "C").PasteSpecial Paste:=xlValues
            a = a + 5
        Next
        Application.CutCopyMode = False
        Target.Select
        Exit Sub
        Application.ScreenUpdating = True
    End If
End If
10:
    For i = 3 To 38 Step 5
        Range("C" & i & ":E" & i + 2).ClearContents
    Next
    Exit Sub

End Sub

 

[karakoc39]

ELİNE SAĞLIK
SÜPER .....