- Katılım
- 22 Ağustos 2022
- Mesajlar
- 40
- Excel Vers. ve Dili
- 2016
iyi geceler arkadaşlar
forum keza sizlerin sayesinde bir şeyler yapmaya çalışıyorum.
alttaki kod pc nin birinde çalışırken öbüründe Subscript out of range gibi bir hata verdi ,
forumda aynı hata kodlarına baktım ama işin içinden çıkamadım ..
kodun neden hata verdiğini keza gereksiz eklediğim vs yerleri söyleyebilirseniz sevinirim
teşekkür ederim .
forum keza sizlerin sayesinde bir şeyler yapmaya çalışıyorum.
alttaki kod pc nin birinde çalışırken öbüründe Subscript out of range gibi bir hata verdi ,
forumda aynı hata kodlarına baktım ama işin içinden çıkamadım ..
kodun neden hata verdiğini keza gereksiz eklediğim vs yerleri söyleyebilirseniz sevinirim
teşekkür ederim .
Kod:
Option Explicit
Sub AFYON()
Dim answer As Integer
answer = MsgBox("işlem başlasın mı ? ", vbYesNo + vbApplicationModal)
If answer = vbYes Then
Else
Exit Sub
End If
Workbooks("BURHAN").Worksheets("BURHAN").Range("A1:P200").Copy _
Workbooks("BRHN").Worksheets("BRHN").Range("P1")
Workbooks("BRHN").Worksheets("BRHN").Activate
Dim k, sonsatir, i, j, h, x As Integer
sonsatir = Cells(Rows.Count, "A").End(3).Row
For h = 1 To 200
Cells(h, 1) = Left(Cells(h, 1), 15)
Cells(h, 16) = Left(Cells(h, 16), 15)
Range("A" & h) = Trim(Range("A" & h))
Range("P" & h) = Trim(Range("P" & h))
Next h
Columns("X:Z").Delete
Columns("Q:V").Delete
Columns("I:I").Insert
Columns("M:M").Insert
Columns("H:H").Delete
Columns("G:G").Delete
Columns("E:E").Delete
Columns("C:C").Delete
Columns("D:D").Cut Columns("I:I")
Columns("D:D").Delete
For k = 1 To sonsatir
Cells(k, 4).Value = WorksheetFunction.IfError(Application.VLookup((Cells(k, 1)), Range("M1:N200"), 2, False), "")
If Cells(k, 4).Value + Cells(k, 8).Value <> 0 Then
Cells(k, 12).Value = Cells(k, 4).Value + Cells(k, 8).Value
ElseIf Cells(k, 4).Value + Cells(k, 8).Value = 0 Then
Cells(k, 12).Value = ""
End If
Next k
'Range("M1:W200").Delete
Range("G:G").Insert
Range("D:D").Cut Range("G:G")
Range("D:D").Delete
Range("L:L").Font.Size = 25
Range("H:H").Font.Size = 25
Range("L:L").Font.Bold = True
Range("H:H").Font.Bold = True
Range("A1: L" & sonsatir).Select
Range("K:K").Clear
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
End With
Range("A1: L" & sonsatir).EntireColumn.AutoFit
For j = 4 To 12
For i = 2 To sonsatir
If Cells(i, j) > 0 Then
Cells(i, j).Interior.ColorIndex = 42
ElseIf Cells(i, j) < 0 Then
Cells(i, j).Interior.ColorIndex = 26
Else
Cells(i, j).Interior.Color = vbYellow
End If
Next i
Next j
For x = 2 To 200
Cells(x, 15).Value = WorksheetFunction.IfError(Application.VLookup((Cells(x, 13)), Range("A2:A200"), 1, False), "")
If Cells(x, 15) <> "" Then
Cells(x, 13).Clear
Cells(x, 14).Clear
Cells(x, 15).Clear
End If
Next x
Columns("M:N").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Range("M:M").Insert
Range("M:M").Clear
Range("A1: L" & sonsatir).EntireColumn.AutoFit
MsgBox " İŞLEM BİTTİ", vbOK + vbApplicationModal
End Sub
