Excel vba kodlarda revize

[1903emre34@gmail.com]

Merhaba arkadaşlar,

Sayfa2'de yer alan 10* ve 13* kurtulmak için aşağıdaki kodlar nasıl değişiklik yapabiliriz? (istenen sayfa3 yapılmıştır)

Sub HesapKodu()

Dim i As Long, k As Long, SonSat As Long
Dim a As Variant, b As Variant
Dim Sh1 As Worksheet, Sh2 As Worksheet

Set Sh1 = Sheets("Sayfa1")

Set Sh2 = Sheets("Sayfa2")


Sh2.Select

    Range("A3:H5555").Select
    Selection.ClearContents
    Range("A2").Select
    
       

Sh1.Select

 Range("A2").Select
  
  

k = 4

SonSat = Sh1.Range("A65555").End(xlUp).Row

For i = 3 To SonSat


a = Sh1.Cells(i, 1)

b = Right(a, 4)


        If Not IsNumeric(b) Then

 
                Sh2.Cells(k, 2) = Left(a, 3)
                Sh2.Cells(k, 3) = Sh1.Cells(i, 2)
                Sh2.Cells(k, 4) = Sh1.Cells(i, 3)
                Sh2.Cells(k, 5) = Sh1.Cells(i, 4)
                Sh2.Cells(k, 6) = Sh1.Cells(i, 5)
                Sh2.Cells(k, 7) = Sh1.Cells(i, 6)
                Sh2.Cells(k, 8) = Sh1.Cells(i, 7)

                k = k + 1


        End If

Next i


Sh2.Select

Set Sh1 = Nothing

Set Sh2 = Nothing

Application.ScreenUpdating = True
MsgBox " ..", vbInformation, "..::  ::.."
End Sub

 

[Korhan Ayhan]

Deneyiniz.

Sub HesapKodu()
    Dim i As Long, k As Long, SonSat As Long
    Dim a As Variant, b As Variant
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    
    Application.ScreenUpdating = False
    
    Set Sh1 = Sheets("Sayfa1")
    Set Sh2 = Sheets("Sayfa2")
    
    Sh2.Select
    Range("A3:H5555").Select
    Selection.ClearContents
    Range("A2").Select
    
    Sh1.Select
    Range("A2").Select
    
    k = 4
    SonSat = Sh1.Range("A65555").End(xlUp).Row
    
    For i = 3 To SonSat
        a = Sh1.Cells(i, 1)
        b = Right(a, 4)
        
        If Not IsNumeric(b) Then
            If InStr(1, Left(a, 3), "*") = 0 Then
                Sh2.Cells(k, 2) = Left(a, 3)
                Sh2.Cells(k, 3) = Sh1.Cells(i, 2)
                Sh2.Cells(k, 4) = Sh1.Cells(i, 3)
                Sh2.Cells(k, 5) = Sh1.Cells(i, 4)
                Sh2.Cells(k, 6) = Sh1.Cells(i, 5)
                Sh2.Cells(k, 7) = Sh1.Cells(i, 6)
                Sh2.Cells(k, 8) = Sh1.Cells(i, 7)
                k = k + 1
            End If
        End If
    Next i
    
    Sh2.Select
    
    Set Sh1 = Nothing
    Set Sh2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[1903emre34@gmail.com]

Teşekkürler, Korhan bey,

İyi çalışmalar