makro birleştirme

[igultekin2000]

iyi akşamlar; kullanmakta olduğum makroya ilaveler yaptım, call olarak tek butonla çalıştırıyorum. bayağı yavaş işlem yapıyor. bu makroları birleştirip daha daha pratik yapabilir miyim.

Sub hspno_getir()
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Dim s As Worksheet
Dim a As Long, b As Long, c As Long
Dim MM
Set s = Sheets("FIS_DTY")
Sheets("FIS_DTY").Range("A4:I65536").ClearContents
MM = 4
For a = 1 To Sheets.Count
    If s.Cells(2, "A") Like Sheets(a).Name Then
        For b = 2 To Sheets(a).Cells(65536, "A").End(3).Row
        If s.Cells(2, "B") = Sheets(a).Cells(b, "B") Then
            For c = 1 To 9
            s.Cells(MM, c) = Sheets(a).Cells(b, c)
            Next
            MM = MM + 1
        End If
        Next
    End If
Next
Sheets("FIS_DTY").Range("A4:I" & Range("I65536").End(3).Row).Font.Name = "Calibri"
Sheets("FIS_DTY").Select
Sheets("FIS_DTY").Range("A4:I" & Range("I65656").End(3).Row).Font.Size = 11 'yazı tipi boyutu
Sheets("FIS_DTY").Select
Sheets("FIS_DTY").Range("D4:G" & Range("G65656").End(3).Row).NumberFormat = "#,##0.00"
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

Sub damga()
 On Error Resume Next
 Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Son = Cells(ActiveSheet.Rows.Count, "G").End(xlUp).Row
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    Cells.Replace Chr(160), ""
    For Each huc In ActiveSheet.Range("D4:G" & Son) 'UsedRange
        huc.Select
        huc.Value = Trim(huc.Value)
    Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub
Sub fisnosayi1()
    NoA = Cells(ActiveSheet.Rows.Count, "D").End(xlUp).Row
    For i = 4 To NoA
        Range("D" & i) = Range("D" & i) + 0
    Next
End Sub

Sub fisnosayi2()
    NoA = Cells(ActiveSheet.Rows.Count, "e").End(xlUp).Row
    For i = 4 To NoA
        Range("e" & i) = Range("e" & i) + 0
    Next
End Sub
Sub fisnosayi3()
    NoA = Cells(ActiveSheet.Rows.Count, "f").End(xlUp).Row
    For i = 4 To NoA
        Range("f" & i) = Range("f" & i) + 0
    Next
End Sub
Sub fisnosayi4()
    NoA = Cells(ActiveSheet.Rows.Count, "g").End(xlUp).Row
    For i = 4 To NoA
        Range("g" & i) = Range("g" & i) + 0
    Next
End Sub

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodla sayıya dönüştürme işlemini kısa bir sürede yapabilirsiniz. 160 kodlu karakteri sildikten sonra bu kodu çalıştırınız. İyi çalışmalar...

Sub kod()
Range("Z1").Value = 1
Range("Z1").Copy
For a = 4 To 7
    NoA = Cells(ActiveSheet.Rows.Count, a).End(xlUp).Row
    If NoA > 4 Then Range(Cells(4, a), Cells(NoA, a)).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply
Next
Range("Z1").ClearContents
End Sub

 

[igultekin2000]

açıklama

Merhaba,
Aşağıdaki kodla sayıya dönüştürme işlemini kısa bir sürede yapabilirsiniz. 160 kodlu karakteri sildikten sonra bu kodu çalıştırınız. İyi çalışmalar...

Sub kod()
Range("Z1").Value = 1
Range("Z1").Copy
For a = 4 To 7
    NoA = Cells(ActiveSheet.Rows.Count, a).End(xlUp).Row
    If NoA > 4 Then Range(Cells(4, a), Cells(NoA, a)).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply
Next
Range("Z1").ClearContents
End Sub

alacak ve alacak bky olan tutarlar metin olarak kalıyor, sayıya çevrilmiyor.