Açık ve kapalı dosyalarda eşleşen rakamları bulunması

[1903emre34@gmail.com]

Merhaba,

Aşağıdaki kodu linkteki dosya uyguladım, ama olmadı

http://s9.dosya.tc/server2/4rbl8z/2016.zip.html


Private Sub CommandButton1_Click()
[E:F] = Empty
f = ThisWorkbook.Path & "\" & "Mizan.xlsx"
Set Aç = New Excel.Application
On Error Resume Next
Aç.Workbooks.Open f
Set hz = Aç.Workbooks(Dir(f))
Set hzs = hz.Sheets(1)
hzs.Columns("A:A").Replace " ", "", xlPart
For a = 6 To Cells(Rows.Count, "B").End(3).Row
If Cells(a, "B") <> "" Then
bc = deg(Cells(a, "A"))
bc = Replace(bc, " ", "")
Set r = hzs.Range("A:A").Find(bc, , xlValues, xlPart, , , False)
If Not r Is Nothing Then
Select Case hzs.Cells(r.Row, "B")
'---------------------------------------

Case 0
'kapalı =0, açık dosyada=0
'--------------------------------------------------
If Cells(a, "C").Value = 0 Then Cells(a, "E") = "KARŞIDA YOK":

'kapalı =0, açık dosyada 0 dan büyük
'--------------------------------------------------
If Cells(a, "C").Value > 0 Then Cells(a, "E") = "YANLIŞ: BURADA FAZLA KARŞIDA SIFIR "

'açık dosyadaki ile kapalı dosyadaki "c" sütunu eşitse
'---------------------------------------------------------
Case Is = Cells(a, "C").Value
Cells(a, "E") = "DOĞRU":

'açık dosyadaki ile kapalı dosyadaki "c" sütunda var ama eşit değil
'-------------------------------------------------------------------------
Case Is <> Cells(a, "C").Value

If Cells(a, "C").Value = 0 And hzs.Cells(r.Row, "B") > 0 Then _
Cells(a, "E") = "YANLIŞ: BURADA FAZLA KARŞIDA SIFIR ": GoTo devam

If Cells(a, "C").Value > 0 And hzs.Cells(r.Row, "B") > 0 Then _
Cells(a, "E") = "YANLIŞ": GoTo devam
'----------------------------------------------------------------
End Select

Else
'----------------------------------------
'açık dosyada var ama kapalı "a" sütununda bulunamadı
If Cells(a, "C") > 0 Then Cells(a, "E") = "DİKKAT"
If Cells(a, "C") = 0 Then Cells(a, "E") = "KARŞIDA YOK"
End If: End If
devam:
If Err > 0 Then
MsgBox "bir hata oluştu programdan çıkılacak"
Exit For
End If
Next
hz.Close SaveChanges:=False
Aç.Quit
Set Aç = Nothing: Set hz = Nothing
End Sub
Function deg(AnyStr As String)
Dim fz
Set fz = CreateObject("vbscript.regexp")
With fz
.Global = True
.Pattern = "[\d]+-"
Set matches = .Execute(sContent)
End With
deg = fz.Replace(AnyStr, "")
deg = Replace(deg, "(-)", "")
Set fz = Nothing
End Function

 

[1903emre34@gmail.com]

Konu güncel

 

[PLİNT]

Merhaba
Ek dosyayı deneyin, yukarıda kodların örnek dosyanıza uygulanmış halidir.
http://s5.dosya.tc/server4/ogzing/2016.zip.html

[SIZE="2"]Private Sub CommandButton1_Click()
cr = Cells(Rows.Count, "C").End(3).Row
hr = Cells(Rows.Count, "H").End(3).Row
For Each hcr1 In Range("C10:C" & cr & "," & "H10:H" & hr)
If hcr1.Value <> "" And hcr1.HasFormula = False Then Cells(hcr1.Row, hcr1.Column + 2) = ""
Next
f = ThisWorkbook.Path & "\" & "MİZAN.xlsx"
Set Aç = New Excel.Application
On Error Resume Next

Aç.Workbooks.Open f
Set hz = Aç.Workbooks(Dir(f))
Set hzs = hz.Sheets(1)
For Each hcr In Range("C10:C" & cr & "," & "H10:H" & hr)
If hcr.Value <> "" And hcr.HasFormula = False Then
Set r = hzs.Range("A:A").Find(Trim(hcr.Text), , xlValues, xlWhole, , , False)
If Not r Is Nothing Then
Select Case hzs.Cells(r.Row, "E").Value
Case 0
'kapalı =0, açık dosyada=0
'--------------------------------------------------
If Cells(hcr.Row, hcr.Column + 1).Value = 0 Then Cells(hcr.Row, hcr.Column + 2) = "KARŞIDA YOK":
[COLOR="Blue"]If Cells(hcr.Row, hcr.Column + 1).Value = 0 And _
hzs.Cells(r.Row, "F").Value = 0 Then
Cells(hcr.Row, hcr.Column + 2) = "DOĞRU":
End If[/COLOR]
'kapalı =0, açık dosyada 0 dan büyük
'--------------------------------------------------
If Cells(hcr.Row, hcr.Column + 1).Value > 0 Then Cells(hcr.Row, hcr.Column + 2) = "YANLIŞ: BURADA FAZLA KARŞIDA SIFIR "

'açık dosyadaki ile kapalı dosyadaki "c" sütunu eşitse
'---------------------------------------------------------
Case Is = Cells(hcr.Row, hcr.Column + 1).Value
Cells(hcr.Row, hcr.Column + 2) = "DOĞRU":

'açık dosyadaki ile kapalı dosyadaki "c" sütunda var ama eşit değil
'-------------------------------------------------------------------------
Case Is <> Cells(hcr.Row, hcr.Column + 1).Value

If Cells(hcr.Row, hcr.Column + 1).Value = 0 And hzs.Cells(r.Row, "B") > 0 Then _
Cells(hcr.Row, hcr.Column + 2) = "YANLIŞ: KARŞIDA FAZLA BURADA SIFIR": GoTo devam

If Cells(hcr.Row, hcr.Column + 1).Value > 0 And hzs.Cells(r.Row, "B") > 0 Then _
Cells(hcr.Row, hcr.Column + 2) = "YANLIŞ": GoTo devam
'----------------------------------------------------------------
End Select

Else
'----------------------------------------
'açık dosyada var ama kapalı "a" sütununda bulunamadı
If Cells(hcr.Row, hcr.Column + 1) > 0 Then Cells(hcr.Row, hcr.Column + 2) = "DİKKAT"
If Cells(hcr.Row, hcr.Column + 1) = 0 Then Cells(hcr.Row, hcr.Column + 2) = "KARŞIDA YOK"
End If: End If
devam:
If Err > 0 Then
MsgBox "bir hata oluştu programdan çıkılacak"
Exit For
End If
Next
hz.Close SaveChanges:=False
Aç.Quit
Set Aç = Nothing: Set hz = Nothing

End Sub

 [/SIZE]

 

[1903emre34@gmail.com]

Hocam, teşekkür ederim,

Mizan sayfasında var ve "E" ve "F" her iki sutünda 0,00 TL ise, KARŞIDA YOK kelimesinin yerine DOĞRU kelimesi getirebilirmiyiz (Örneğin 100 hesabı)

 

[PLİNT]

Hocam, teşekkür ederim,

Mizan sayfasında var ve "E" ve "F" her iki sutünda 0,00 TL ise, KARŞIDA YOK kelimesinin yerine DOĞRU kelimesi getirebilirmiyiz (Örneğin 100 hesabı)

Kodları yukarıdaki değişen haliyle deneyelim.

 

[1903emre34@gmail.com]

çok teşekkürler