• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Nokta, Virgül Değiştir

  • Konbuyu başlatan Konbuyu başlatan halit3
  • Başlangıç tarihi Başlangıç tarihi
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,878
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu uygulama Nokta ve virgüllerin yer değişimi ile ilgilidir.
Bu kod seçilen bölüm ile ilgili noktaları virgül , Virgülleri nokta yapar.

kod:



Kod: 
Sub noktavirgulduzelt()

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

Dim cell As Range

nokta = "."
virgul = ","

For Each cell In ActiveWindow.RangeSelection.Cells



deg1 = Split(cell.Value, nokta)
deg2 = Split(cell.Value, virgul)

hucre = cell.NumberFormat
cell.NumberFormat = "@"
veri = ""
k = 0
kk = 0
If IsNumeric(cell.Value) = True Then
If UBound(deg1) > 0 Then
For i = 0 To Val(UBound(deg1))
k = k + 1
If k = 1 Then
veri = deg1(i)
Else
veri = veri & virgul & deg1(i)
End If
Next

If UBound(deg1) = 1 Then
cell.Value = veri * 1
Else
cell.Value = veri
End If

ElseIf UBound(deg2) > 0 Then

For i = 0 To Val(UBound(deg2))
kk = kk + 1
If kk = 1 Then
veri = deg2(i)
Else
veri = veri & nokta & deg2(i)
End If
Next
cell.Value = veri
Else
cell.Value = veri
End If

Else

If UBound(deg1) Then
For i = 0 To Val(UBound(deg1))
k = k + 1
If k = 1 Then
veri = deg1(i)
Else
veri = veri & virgul & deg1(i)
End If
Next
cell.Value = veri
End If

If UBound(deg2) Then
For i = 0 To Val(UBound(deg2))
kk = kk + 1
If kk = 1 Then
veri = deg2(i)
Else
veri = veri & nokta & deg2(i)
End If
Next
cell.Value = veri
End If

cell.Value = cell.Value

End If
cell.NumberFormat = hucre
Next

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With

End Sub
 

Ekli dosyalar

Bu kod seçilen bölüm ile ilgili noktaları virgül yapar.

Kod: 
Sub virgulyap()

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
nokta = "."
virgul = ","

Dim cell As Range

For Each cell In ActiveWindow.RangeSelection.Cells
deg1 = Split(cell.Value, nokta)

hucre = cell.NumberFormat
cell.NumberFormat = "@"
veri = ""
k = 0

If IsNumeric(cell.Value) = True Then

If UBound(deg1) > 0 Then
For i = 0 To Val(UBound(deg1))
k = k + 1
If k = 1 Then
veri = deg1(i)
Else
veri = veri & virgul & deg1(i)
End If
Next

If UBound(deg1) = 1 Then
cell.Value = veri * 1
Else
cell.Value = veri
End If

Else
cell.Value = cell.Value
End If

Else

If UBound(deg1) > 0 Then
For i = 0 To Val(UBound(deg1))
k = k + 1
If k = 1 Then
veri = deg1(i)
Else
veri = veri & virgul & deg1(i)
End If
Next
cell.Value = veri
Else
cell.Value = cell.Value
End If

End If
cell.NumberFormat = hucre
Next

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With

End Sub
 
Bu kod seçilen bölüm ile ilgili Virgülleri nokta yapar.

Kod: 
Sub noktayap()

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
Dim cell As Range
nokta = "."
virgul = ","
For Each cell In ActiveWindow.RangeSelection.Cells
deg2 = Split(cell.Value, virgul)
hucre = cell.NumberFormat
cell.NumberFormat = "@"
veri = ""
k = 0
If IsNumeric(cell.Value) = True Then

If UBound(deg2) > 0 Then
For i = 0 To Val(UBound(deg2))
k = k + 1
If k = 1 Then
veri = deg2(i)
Else
veri = veri & nokta & deg2(i)
End If
Next
cell.Value = veri
Else
cell.Value = cell.Value
End If

Else

If UBound(deg2) > 0 Then
For i = 0 To Val(UBound(deg2))
k = k + 1
If k = 1 Then
veri = deg2(i)
Else
veri = veri & nokta & deg2(i)
End If
Next
cell.Value = veri
Else
cell.Value = cell.Value
End If

End If
cell.NumberFormat = hucre
Next

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With

End Sub
 
Halit bey, teşekkürler güzel çalışma olmuş

ekte dosyada, seçilen bölüm ilgili olarak noktalar ve virgüller yer değiştirecek şekilde ekleme yapabilirmiyiz

iyi çalışmalar
 

Ekli dosyalar

1903emre34@gmail.com' Alıntı:
Halit bey, teşekkürler güzel çalışma olmuş

ekte dosyada, seçilen bölüm ilgili olarak noktalar ve virgüller yer değiştirecek şekilde ekleme yapabilirmiyiz

iyi çalışmalar
Genişletmek için tıkla ...

bunu bir deneyiniz.

Kod: 
Sub noktavirgulduzelt2()

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

Dim cell As Range

nokta = "."
virgul = ","

For Each cell In ActiveWindow.RangeSelection.Cells

deg3 = Split(cell.Value, nokta)
deg4 = Split(cell.Value, virgul)

hucre = cell.NumberFormat
cell.NumberFormat = "@"


If UBound(deg3) > 0 And UBound(deg4) > 0 Then
cell.Value = Replace(Replace(cell.Value, nokta, "#"), virgul, "&")
End If

deg5 = Split(cell.Value, "#")
deg6 = Split(cell.Value, "&")

If UBound(deg5) > 0 And UBound(deg6) > 0 Then
cell.Value = Replace(Replace(cell.Value, "#", virgul), "&", nokta)
End If

cell.NumberFormat = hucre
Next

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With

End Sub
 
Bu kod da farklı uygulama

Kod: 
Sub noktavirgulduzelt4()


son = Application.Calculation '-4105
'MsgBox Application.Calculation '-4135

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With

Dim cell As Range

nokta = "."
virgul = ","

For Each cell In ActiveWindow.RangeSelection.Cells

deg3 = Split(cell.Value, nokta)
deg4 = Split(cell.Value, virgul)

hucre = cell.NumberFormat
If IsDate(cell.Value) = True Then GoTo atla2

cell.NumberFormat = "@"

If UBound(deg3) > 0 And UBound(deg4) > 0 Then

cell.Value = Replace(Replace(cell.Value, nokta, "[#]"), virgul, "[&]")
End If

deg5 = Split(cell.Value, "[#]")
deg6 = Split(cell.Value, "[&]")

If UBound(deg5) > 0 And UBound(deg6) > 0 Then

cell.Value = Replace(Replace(cell.Value, "[#]", virgul), "[&]", nokta)
GoTo atla
End If

If UBound(deg3) > 0 And UBound(deg4) = 0 Then
cell.Value = Replace(cell.Value, nokta, virgul)
If IsNumeric(cell.Value) = True Then
cell.Value = cell.Value * 1
End If
GoTo atla
End If

If UBound(deg4) > 0 And UBound(deg3) <= 0 Then
cell.Value = Replace(cell.Value, virgul, nokta)
GoTo atla
End If

atla2:
 
If IsDate(cell.Value) = True Then
cell.Value = Replace(Replace(cell.Value, nokta, "[#]"), virgul, "[&]")
cell.Value = Replace(Replace(cell.Value, "[#]", virgul), "[&]", nokta)
End If

atla:
cell.NumberFormat = hucre
Next

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = son
End With


End Sub
 
Merhaba halit bey, ben butona tıklayınca belli bir bölümdeki "," (virgül) lerin, "." (nokta) ile "." (nokta) ların da "," (virgül) ile değişmesini istiyorum, aşağıdaki kodu denedim ama, aynı anda yaptıramadığım için amacıma ulaşamadım.


Kod: 
Sub Düğme1_Tıkla()
Dim sayac, c As Integer
Dim primtutari As String

sayac = [Sayfa1!A1].CurrentRegion.Rows.Count
MsgBox sayac

For c = 1 To sayac Step 1
primtutari = Range("L" & c).Value
Range("L" & c).Value = Replace(Replace(primtutari, ".", ","), ".", ",")
Next
End Sub
 
Aşağıdaki şekilde deneyebilir misiniz?
Kod: 
Sub Düğme1_Tıkla()
Dim sayac, c As Integer
Dim primtutari As String

sayac = [Sayfa1!A1].CurrentRegion.Rows.Count
'MsgBox sayac

For c = 1 To sayac Step 1
'primtutari = Range("L" & c).Value
Range("L" & c).Value = Replace(Range("L" & c).Value, ".", "-")
Range("L" & c).Value = Replace(Range("L" & c).Value, ",", ".")
Range("L" & c).Value = Replace(Range("L" & c).Value, "-", ",")
Next
End Sub
 
Evet oldu teşekkürler, bende şöyle birşey yapıp sorunu çözdüm aslında posttan sonra;

Kod: 
Range("L" & c).Value = Replace(Replace(primtutari, ",", ""), ".", ",")

virgülü kaldırıp, noktayı değiştirerek. Yani örneği; 17,572.00 sayısını, 17572,00 yaptı.
 
EthemX' Alıntı:
Merhaba halit bey, ben butona tıklayınca belli bir bölümdeki "," (virgül) lerin, "." (nokta) ile "." (nokta) ların da "," (virgül) ile değişmesini istiyorum, aşağıdaki kodu denedim ama, aynı anda yaptıramadığım için amacıma ulaşamadım.


Kod: 
Sub Düğme1_Tıkla()
Dim sayac, c As Integer
Dim primtutari As String

sayac = [Sayfa1!A1].CurrentRegion.Rows.Count
MsgBox sayac

For c = 1 To sayac Step 1
primtutari = Range("L" & c).Value
Range("L" & c).Value = Replace(Replace(primtutari, ".", ","), ".", ",")
Next
End Sub
Genişletmek için tıkla ...

7 nolu mesajdaki kod bu işlemi yapıyor seçili alanı kod birinci tıklamada farklı ikinci tıklamada farklı işlem yapıyor
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst