Harfleri A sutunundan B sutununa taşıma

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Merhaba.
Aşağıdaki kodları denermisiniz.:cool:
Sanırım bu sefer oldu.:cool:
Kod:
Sub aktar2()
Sheets("Sayfa1").Select
Range("B:B").ClearContents
sat = 1
For i = 1 To Cells(65536, "A").End(xlUp).Row
    For k = 1 To Len(Cells(i, "A").Value)
    If Not IsNumeric(Mid(Range("A" & i), k, 1)) Then metin = 1
    Next k
    If metin = 1 Then
        metin = 0
        Cells(sat, "B").Value = Cells(i, "A").Value
        Cells(i, "A").Value = ""
        sat = sat + 1
    End If
Next i
Range("A1:A" & i - 1).SpecialCells(xlCellTypeBlanks).Delete (xlUp)
MsgBox "Aktarma işlemi tamamlandı..!!", vbOKOnly, Application.UserName
End Sub
 
Katılım
7 Aralık 2006
Mesajlar
37
Excel Vers. ve Dili
exel2003 tr
Ben uğraşırken Sayın yurttaş işe son noktayı koymuş.
Sn. Cost_Control, kombo ve Sn. Yurttas

işlemim çözüme kavuştu. Hepinize Teşekkür ederim. Degerli zamanınızı ayırdıgınız için. Hepinizin örnekleri sayfamda calıştı, bir problem yok.

İyiki varsın excel.web.tr
 
Katılım
7 Aralık 2006
Mesajlar
37
Excel Vers. ve Dili
exel2003 tr
[/B][/COLOR]
Merhaba.
Aşağıdaki kodları denermisiniz.:cool:
Sanırım bu sefer oldu.:cool:
Kod:
Sub aktar2()
Sheets("Sayfa1").Select
Range("B:B").ClearContents
sat = 1
For i = 1 To Cells(65536, "A").End(xlUp).Row
    For k = 1 To Len(Cells(i, "A").Value)
    If Not IsNumeric(Mid(Range("A" & i), k, 1)) Then metin = 1
    Next k
    If metin = 1 Then
        metin = 0
        Cells(sat, "B").Value = Cells(i, "A").Value
        Cells(i, "A").Value = ""
        sat = sat + 1
    End If
Next i
Range("A1:A" & i - 1).SpecialCells(xlCellTypeBlanks).Delete (xlUp)
MsgBox "Aktarma işlemi tamamlandı..!!", vbOKOnly, Application.UserName
End Sub

Sn.Sezar sizede teşekkür ederim. İşlemim oldu. Ancak Excelimi geliştirmek için sizin örneginizide inceleyecegim.

İşte excel.web.tr.
yarım saatte onca cevap ve hepside birbirinden farklı ve hepside dogru calısan örnekler.
İYİKİ VARSIN EXCEL.WEB.TR
 
Katılım
24 Mayıs 2007
Mesajlar
9
Excel Vers. ve Dili
türkçe office XP
İlgİlİ Dosyayi GÖnder İstedİĞİn Hale Getİrİp Sana Gerİ GÖndereyİm
 

N.Ziya Hiçdurmaz

Özel Üye
Katılım
28 Nisan 2007
Mesajlar
2,218
Excel Vers. ve Dili
Office 2013 TR / 32 Bit
Makrolu bir çözümde benden.
Sub test()
yerine = [a1:a1000]
For i = 1 To [a65000].End(3).Row
s = WorksheetFunction.CountA([b1:B65000])
If Range("a" & i) <> Val(Range("a" & i)) Then
Range("a" & i).Copy
Range("b" & s + 1).PasteSpecial
End If
Next
For sil = [b65536].End(3).Row To 1 Step -1
If Val(Range("B" & sil)) Then
Rows(sil).Delete
[a1:a1000] = yerine
End If
Next
End Sub
 
Üst