Aktarma Makrosunun Hücre Başındaki Boşlukların Silinmesi

[akmes]

Merhaba, Aşağıdaki koda, ilgili sayfadan diğer sayfaya aktarıldığında verilerin hücre başında boşluk olmadan sola yaslanarak aktarılması için nasıl bir satır ekleyebiliriz.
Birde aşağıdaki kod çok ağır çalışıyor uzun süre beklemem gerekiyor işimi görecek daha hızlı bir kod var mıdır?

Yardımlarınıza şimdiden çok teşekkür ederim.


Sub aktar()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("Data")
For i = 2 To 60000
Set s2 = ThisWorkbook.Worksheets(s1.Cells(i, 63).Value)
sonsatir = s2.Range("C65536").End(xlUp).Row + 1
s2.Cells(sonsatir, 3) = s1.Cells(i, 21) '1.TAKIM
s2.Cells(sonsatir, 4) = s1.Cells(i, 26) '1.TAKIM ATTIGI GOL
s2.Cells(sonsatir, 5) = s1.Cells(i, 27) '2.TAKIM ATTIGI GOL
s2.Cells(sonsatir, 6) = s1.Cells(i, 22) '2.TAKIM
s2.Cells(sonsatir, 7) = s1.Cells(i, 64) 'Do_rulama
Set s2 = Nothing
Next i
MsgBox "Aktarma __lemi B_TT_.", vbInformation
End Sub

 

[Orion1]

Örnek dosya linkini veriniz.

 

[akmes]

Örnek dosya linkini veriniz.

Merhaba Üstadım,

Dosya ektedir.

http://s3.dosya.tc/server30/eCgxMB/Kitap21.zip.html

Üstadım ilgili sayfaya mesela AL1 sayfasında aktarım yaptıktan sonra Z sütununa farklı 18 takımı yazdığımda sadece 7 maçları var gösteriyor. Aslında 14 maçlık karşılaşmaları var.İsimlerine baktığımızda ilk etapta F sütunundakilerin önünde boşluk var ondan diye düşündüm ama onları elle tek tek kaldırdığım halde 14 maç olarak göremedim.Bu konudada yardımcı olursanız çok minnettar kalırım.

 

[Orion1]

Merhaba, Aşağıdaki koda, ilgili sayfadan diğer sayfaya aktarıldığında verilerin hücre başında boşluk olmadan sola yaslanarak aktarılması için nasıl bir satır ekleyebiliriz.
Birde aşağıdaki kod çok ağır çalışıyor uzun süre beklemem gerekiyor işimi görecek daha hızlı bir kod var mıdır?

Yardımlarınıza şimdiden çok teşekkür ederim.

İlgili sayfa adı ve diğer sayfa adı nedir?

 

[akmes]

İlgili sayfa adı ve diğer sayfa adı nedir?

Pardon üstadım, DATA sayfasından AL1,AL2 ve diğer sekmelere aktarım yaptığımda Örnek AL1 sayfasında baktığımızda C sütununa gelen takım isimleri sağa yaslanmış olarak geliyor F sütununa gelen veriler 1 veya 2 boşluktan sonra geliyor. Böyle olunca AL1 sayfasında Z2 ile Z19 arasına ben 18 takımın ismini yazdığımda o sayfaya aktardığım tüm maçları ile ilgili puan cetvelim oluşmuyor. Örn.Z2 hücresine Mainz yazdığımda AP2 hücresinde 7 maç yapmış gözüküyor aslında aktardığım verileri göre 14 maçı var.

 

[Orion1]

dosyanız ektedir.

Sub aktar59()
Dim sonsatir As Long, son As Long
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("DATA")
son = s1.Cells(Rows.Count, "BK").End(xlUp).Row
Application.Calculation = xlCalculationManual
For i = 3 To Worksheets.Count
    Sheets(i).Range("C2:G" & Rows.Count).ClearContents
Next i
For i = 2 To son
Set s2 = ThisWorkbook.Worksheets(s1.Cells(i, 63).Value)
sonsatir = s2.Range("C65536").End(xlUp).Row + 1
s2.Cells(sonsatir, 3) = Replace(s1.Cells(i, 21), Chr(160), "") '1.TAKIM
s2.Cells(sonsatir, 4) = s1.Cells(i, 26) '1.TAKIM ATTIGI GOL
s2.Cells(sonsatir, 5) = s1.Cells(i, 27) '2.TAKIM ATTIGI GOL
s2.Cells(sonsatir, 6) = Replace(s1.Cells(i, 22), Chr(160), "") '2.TAKIM
s2.Cells(sonsatir, 7) = Replace(s1.Cells(i, 64), Chr(160), "") 'Do_rulama
Set s2 = Nothing
Next i
Application.Calculation = xlCalculationAutomatic
MsgBox "Aktarma __lemi B_TT_.", vbInformation
End Sub

 

[akmes]

dosyanız ektedir.

Sub aktar59()
Dim sonsatir As Long, son As Long
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("DATA")
son = s1.Cells(Rows.Count, "BK").End(xlUp).Row
Application.Calculation = xlCalculationManual
For i = 3 To Worksheets.Count
    Sheets(i).Range("C2:G" & Rows.Count).ClearContents
Next i
For i = 2 To son
Set s2 = ThisWorkbook.Worksheets(s1.Cells(i, 63).Value)
sonsatir = s2.Range("C65536").End(xlUp).Row + 1
s2.Cells(sonsatir, 3) = Replace(s1.Cells(i, 21), Chr(160), "") '1.TAKIM
s2.Cells(sonsatir, 4) = s1.Cells(i, 26) '1.TAKIM ATTIGI GOL
s2.Cells(sonsatir, 5) = s1.Cells(i, 27) '2.TAKIM ATTIGI GOL
s2.Cells(sonsatir, 6) = Replace(s1.Cells(i, 22), Chr(160), "") '2.TAKIM
s2.Cells(sonsatir, 7) = Replace(s1.Cells(i, 64), Chr(160), "") 'Do_rulama
Set s2 = Nothing
Next i
Application.Calculation = xlCalculationAutomatic
MsgBox "Aktarma __lemi B_TT_.", vbInformation
End Sub

Evren Üstadım, emeğinize sağlık tam istediğim gibi olmuş, allah razı olsun, çok teşekkür ederim.