Harfleri A sutunundan B sutununa taşıma

[Orion1]

Merhaba.
Aşağıdaki kodları denermisiniz.
Sanırım bu sefer oldu.

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

 

[yamtar155]

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

 

[yamtar155]

[/B][/COLOR]

Merhaba.
Aşağıdaki kodları denermisiniz.
Sanırım bu sefer oldu.

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

 

[KAYALARLI]

İlgİlİ Dosyayi GÖnder İstedİĞİn Hale Getİrİp Sana Gerİ GÖndereyİm

 

[yamtar155]

İlgİlİ Dosyayi GÖnder İstedİĞİn Hale Getİrİp Sana Gerİ GÖndereyİm

Sn.KAYALARLI
İLGİNE TEŞEKKÜRLER SORUNUM CÖZÜLDÜ. YİNE DE SAOLASIN..

 

[N.Ziya Hiçdurmaz]

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