hücre değerine göre makro

[alirizapekbilir]

mizan sayfasında B2 hücre değeri "GEÇİCİ TALİ MİZANI" yazıyorsa farklı "KATİ KEBİR MİZANI" yazıyorsa farklı kod çalışsın yoksa hata mesajı versin. aralara kodları ben ekleyeceğim. yardımınızı bekliyorum. dosya büyük eklemek istemedim. teşekkürler


KOD

Sub Deneme()
Sheets("Mizan").Select
If Range("B2") = "GEÇİCİ TALİ MİZANI" Then
'Mizan aktarma bölümü
Sheets("Mizan").Select
Range("B1:Q2000").Select
Selection.Copy
Sheets("Mizan-G").Select
Range("B1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("B6:C6").Select
Range("B7").Select
'Boş satırları ayırma bölümü
Sheets("Mizan-G").Select
Range("A6").Select
ActiveCell.FormulaR1C1 = "=IF(RC[3]="""",0,IF(RC[3]=""HESAP ADI"",0,1))"
Range("A6").Select
Selection.Copy
Range("A6").Select
Range(Selection, Selection.End(xlDown)).Select
Range("A6:A2000").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
'Boş satırları silme bölümü
Sheets("Mizan-G").Select
Range("D15:F15").Select
ActiveSheet.Range("$A$6:$Q$1045054").AutoFilter Field:=1, Criteria1:="0"
Rows("7:2000").Select
Selection.Delete Shift:=xlUp
Range("A6").Select
ActiveSheet.Range("$A$6:$Q$1043899").AutoFilter Field:=1
Range("A1").Select

'Hesap kodu düzeltme bölümü
Range("B7:B1500").Select
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
'Virgül ve noktaları süzeltme
Range("B7:C7").Select
Range(Selection, Selection.End(xlDown)).Select
Range("B7:C2000").Select
Selection.Replace What:=",", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=".", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select
ActiveCell.FormulaR1C1 = ""
Range("A1").Select

MsgBox "Geçici Mizan Aktarıldı..."
Else
Sheets("Mizan").Select
If Range("B2") = "KATİ KEBİR MİZANI" Then
'Mizan aktarma bölümü
Sheets("Mizan").Select
Range("B1:Q2000").Select
Selection.Copy
Sheets("Mizan-K").Select
Range("B1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("B6:C6").Select
Range("B7").Select
'Boş satırları ayırma bölümü
Sheets("Mizan-K").Select
Range("A6").Select
ActiveCell.FormulaR1C1 = "=IF(RC[3]="""",0,IF(RC[3]=""HESAP ADI"",0,1))"
Range("A6").Select
Selection.Copy
Range("A6").Select
Range(Selection, Selection.End(xlDown)).Select
Range("A6:A2000").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
'Boş satırları silme bölümü
Sheets("Mizan-K").Select
Range("D15:F15").Select
ActiveSheet.Range("$A$6:$Q$1045054").AutoFilter Field:=1, Criteria1:="0"
Rows("7:2000").Select
Selection.Delete Shift:=xlUp
Range("A6").Select
ActiveSheet.Range("$A$6:$Q$1043899").AutoFilter Field:=1
Range("A1").Select

'Hesap kodu düzeltme bölümü
Range("B7:B1500").Select
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
'Virgül ve noktaları süzeltme
Range("B7:C7").Select
Range(Selection, Selection.End(xlDown)).Select
Range("B7:C2000").Select
Selection.Replace What:=",", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=".", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select
ActiveCell.FormulaR1C1 = ""
Range("A1").Select

MsgBox "Kati Mizan Aktarıldı..."
Else
MsgBox "Mizan yok..."
End If
End Sub

 

[alirizapekbilir]

not

iki kez else çalışıyormu bilemedim

 

[Ömer BARAN]

Merhaba.

Kodlarınızı incelemedim ama şunu söyleyeyim, aşağıdaki gibi bir yapı düşünebilirsiniz.
.

[B]If [COLOR="blue"]koşul1[/COLOR] Then[/B]
[COLOR="blue"][I]    [B]koşul1[/B] doğru ise yapılacak işlemler[/I][/COLOR]
[B]Elseif [COLOR="Red"]koşul2[/COLOR] Then[/B]
[COLOR="Red"][I]    [B]koşul2[/B] doğru ise yapılacak işlemler[/I][/COLOR]
[B]Else[/B]
[I]    iki koşulda doğru değilse yapılacak işlemler[/I]
[B]End If[/B]

 

[alirizapekbilir]

teşekkürler

teşekkürler düzeldi elinize sağlık