问题描述
我有一组坐标，我想对其进行划分。我想要带有小数的正确数字，这在我的工作表中不会发生，因为我得到了杂乱的数据。
这里我需要带小数的数字。
我试图将它们除以数字，但没有成功。
Sub Coordinatesfinal()
Columns("F:G").Insert Shift:=xlToRight
ActiveSheet.Range("E1").Value = "Latitude"
ActiveSheet.Range("F1").Value = "Longitude"
Dim rang As Range,cell As Range,rg As Range,element As Range,rg2 As Range
Dim r1 As Range,r2 As Range
Dim wors As Worksheet
Set wors = ActiveSheet
Dim myString As String
myString = "."
Dim LastRow As Long,i As Long,SecondLastRow As Long
LastRow = wors.Range("E" & wors.Rows.Count).End(xlUp).Row
Set rang = wors.Range("E2:E" & LastRow)
For Each cell In rang
cell = WorksheetFunction.Substitute(cell,"," ")
cell = WorksheetFunction.Substitute(cell," "," ")
Next
Set rg = [E2]
Set rg = Range(rg,Cells(Rows.Count,rg.Column).End(xlUp))
rg.TextToColumns Destination:=rg,DataType:=xlDelimited,_
TextQualifier:=xlDoubleQuote,ConsecutiveDelimiter:=False,Tab:=False,_
Semicolon:=False,Comma:=False,Space:=True,Other:=False,_
FieldInfo:=Array(Array(1,1),Array(2,Array(3,1)),TrailingMinusNumbers:=True
If InStr(myString,".") > 0 Then
Exit Sub
End If
With words
LastRow = .Cells(.Rows.Count,"E").End(xlUp).Row
SecondLastRow = .Cells(.Rows.Count,"F").End(xlUp).Row
End With
For Each element In wors.Range("E2:E" & LastRow)
cell.Value = cell.Value / 1000000
Next
For i = 2 To LastRow
Set r1 = Range("E" & i)
Set r2 = Range("F" & i)
If r1.Value > 54.5 Or r1.Value < 50 Then r1.Interior.Color = vbYellow
If r2.Value > 2 Or r2.Value < -7 Then r2.Interior.Color = vbCyan
'If r1.Value = 3 Then r2.Interior.Color = vbYellow
Next i
rg.TextToColumns Destination:=rg,Tab:=True,Space:=False,TrailingMinusNumbers:=True
MsgBox ("Coordinates prepared successfully")
End Sub
For Each element In wors.Range("E2:E" & LastRow)
cell.Value = cell.Value / 1000000
Next
VBA: Macro to divide range by a million
根本不起作用，就像：
For Each element In wors.Range("F2:F" & SecondLastRow)
If IsNumeric(element.Value) Then
If Len(element.Value) > 7 And Len(element.Value) < 9 Then
element.Value = element.Value / 1000000
ElseIf Len(element.Value) < 8 Then
element.Value = element.Value / 100000
Else
element.Value = element.Value / 10000000
End If
End If
Next
我不知道问题出在哪里。由于根据我的总字符串长度，我可能有几种情况，我想问一下插入“。”的可能性。我的字符串中第二个字符之后的符号。
我测试了这个功能：
Excel/VBA - How to insert a character in a string every N characters
但没有任何结果。
有什么办法可以将这些数字相除或简单地插入“。”第二个数字后的符号？
这是我想要的输出
解决方法
这样的事情应该可以工作：
Sub Coordinatesfinal()
Dim ws As Worksheet,rngData As Range,arrIn,arrOut,r As Long,d,arr
Set ws = ActiveSheet
Set rngData = ws.Range("E2",ws.Cells(Rows.Count,"E").End(xlUp))
arrIn = rngData.Value 'get input data as array
ReDim arrOut(1 To UBound(arrIn,1),1 To 2) 'size array for output data
'clean raw value
For r = 1 To UBound(arrIn,1)
d = Trim(Replace(arrIn(r,"," ")) 'remove commas
Do While InStr(d," ") > 0
d = Replace(d," "," ") 'remove any double spaces
Loop
arr = Split(d," ") 'split on space
arrOut(r,1) = FormatValue(arr(0)) 'Lat
If UBound(arr) > 0 Then arrOut(r,2) = FormatValue(arr(1)) 'Long
Next r
ws.Columns("F:G").Insert Shift:=xlToRight
ws.Range("F1:G1").Value = Array("Latitude","Longitude")
With ws.Range("F2").Resize(UBound(arrIn,2)
.NumberFormat = "General"
.Value = arrOut
End With
End Sub
'convert to decimal if numeric,according to length
Function FormatValue(ByVal v)
If IsNumeric(v) And InStr(v,".") = 0 Then
v = CLng(v)
Select Case Len(v)
Case 8: FormatValue = v / 1000000
Case Is < 8: FormatValue = v / 100000
Case Else: FormatValue = v / 10000000
End Select
Else
FormatValue = v
End If
End Function
没有对 OP 的完整答案，但是当提供复合字符串时，下面的代码可能有助于返回纬度和经度双精度数组。
Public Const SPACE As String = " "
Public Const COMMA As String = ","
Public Enum Position
latitude
longitude
End Enum
Public Sub ttest()
Dim myArray As Variant
myArray = ConvertLatLongStringToLatLongDoubles(" 51519636 -1081282 ")
Debug.Print myArray(latitude)
Debug.Print myArray(longitude)
End Sub
' Return a variant containing an array of two doubles
' Index 0 is Latitude
' Index 1 is longitude
Public Function ConvertLatLongStringToLatLongDoubles(ByVal ipPosition As String) As Variant
' Clean up the incoming string
Dim myPosition As String
myPosition = Trimmer(ipPosition)
myPosition = Dedup(myPosition,SPACE)
' add other dedups as required as
' SPlit the string at the remaining SPACE
Dim myLatLong As Variant
myLatLong = Split(myPosition)
myLatLong(Position.latitude) = CDbl(myLatLong(Position.latitude)) / 1000000
myLatLong(Position.longitude) = CDbl(myLatLong(Position.longitude)) / 1000000
ConvertLatLongStringToLatLongDoubles = myLatLong
End Function
' Dedup replaces character pairs with a single character
' Dedup operates until no more pairs can be found.
' ipDedup should be a string (usually a single character)
' that need to be deduped
Public Function Dedup(ByVal ipSource As String,ByVal ipDedup As String) As String
Dim mySource As String
mySource = ipSource
Dim MyDedupDedup As String
MyDedupDedup = ipDedup & ipDedup
Do
Dim myLen As Long
myLen = Len(mySource)
mySource = Replace(mySource,MyDedupDedup,ipDedup)
Loop Until myLen = Len(mySource)
Dedup = mySource
End Function
' Trimmer will remove any single character specified in ipTrimChars
' from the start and end of the string
Public Function Trimmer(ByVal ipString As String,Optional ByVal ipTrimChars As String = ",;" & vbCrLf & vbTab) As String
Dim myString As String
myString = ipString
Dim myIndex As Long
For myIndex = 1 To 2
If VBA.Len(myString) = 0 Then Exit For
Do While VBA.InStr(ipTrimChars,VBA.Left$(myString,1)) > 0
DoEvents ' Always put a do event statement in a do loop
myString = VBA.Mid$(myString,2)
Loop
myString = VBA.StrReverse(myString)
Next
Trimmer = myString
End Function