7,763
社区成员
发帖
与我相关
我的任务
分享VB，文本框内容排列的问题?
VB，排列的问题。文本框text1输入aafacacddgd,一按按钮command1,文本框text2就排列成aaaadddccgf。大概意思就是把内容排列成字符相同的最多的列在前边，以多到少的方式排列。请问能不能做得到？请高手教教，谢谢。。
...全文
请发表友善的回复…
发表回复
海牛 2004-08-08
- 打赏
- 举报
在窗体里面添加两个TextBox和一个Command控件
Option Explicit
Private Type MyChar
Char As String
Count As Integer
End Type
'对字符串按要求的进行排序
Private Function SortString(ByVal strSource As String) As String
Dim I As Integer, K As Integer, M As Integer
Dim intLen As Integer, intTmp As Integer
Dim strT As String, strResult As String
Dim arrMyChar() As MyChar, tMyCharTmp As MyChar
K = -1
ReDim arrMyChar(0) As MyChar
intLen = Len(strSource)
For I = 1 To intLen
strT = Mid(strSource, I, 1)
If CheckHaveSameChar(arrMyChar, strT) = False Then
K = K + 1
ReDim Preserve arrMyChar(K) As MyChar
arrMyChar(K).Count = 1
arrMyChar(K).Char = strT
Else
arrMyChar(K).Count = arrMyChar(K).Count + 1
End If
Next
'对数组进行排序
K = UBound(arrMyChar)
For I = 0 To K - 1
intTmp = arrMyChar(I).Count
For M = I + 1 To K
If arrMyChar(M).Count > intTmp Then
tMyCharTmp = arrMyChar(I)
arrMyChar(I) = arrMyChar(M)
arrMyChar(M) = tMyCharTmp
intTmp = arrMyChar(I).Count
End If
Next
strResult = strResult & String(arrMyChar(I).Count, arrMyChar(I).Char)
Next
SortString = strResult & String(arrMyChar(K).Count, arrMyChar(K).Char)
End Function
'检查数组里面是否已经有了strChar字符
Private Function CheckHaveSameChar(arrMyChar() As MyChar, ByVal strChar As String) As Boolean
Dim I As Integer, K As Integer
On Error GoTo Err1
K = UBound(arrMyChar)
For I = 0 To K
If arrMyChar(I).Char = strChar Then
CheckHaveSameChar = True
Exit Function
End If
Next
CheckHaveSameChar = False
Exit Function
Err1:
CheckHaveSameChar = False
End Function
Private Sub Command1_Click()
Me.Text2.Text = SortString(Me.Text1.Text)
End Sub
Option Explicit
Private Type MyChar
Char As String
Count As Integer
End Type
'对字符串按要求的进行排序
Private Function SortString(ByVal strSource As String) As String
Dim I As Integer, K As Integer, M As Integer
Dim intLen As Integer, intTmp As Integer
Dim strT As String, strResult As String
Dim arrMyChar() As MyChar, tMyCharTmp As MyChar
K = -1
ReDim arrMyChar(0) As MyChar
intLen = Len(strSource)
For I = 1 To intLen
strT = Mid(strSource, I, 1)
If CheckHaveSameChar(arrMyChar, strT) = False Then
K = K + 1
ReDim Preserve arrMyChar(K) As MyChar
arrMyChar(K).Count = 1
arrMyChar(K).Char = strT
Else
arrMyChar(K).Count = arrMyChar(K).Count + 1
End If
Next
'对数组进行排序
K = UBound(arrMyChar)
For I = 0 To K - 1
intTmp = arrMyChar(I).Count
For M = I + 1 To K
If arrMyChar(M).Count > intTmp Then
tMyCharTmp = arrMyChar(I)
arrMyChar(I) = arrMyChar(M)
arrMyChar(M) = tMyCharTmp
intTmp = arrMyChar(I).Count
End If
Next
strResult = strResult & String(arrMyChar(I).Count, arrMyChar(I).Char)
Next
SortString = strResult & String(arrMyChar(K).Count, arrMyChar(K).Char)
End Function
'检查数组里面是否已经有了strChar字符
Private Function CheckHaveSameChar(arrMyChar() As MyChar, ByVal strChar As String) As Boolean
Dim I As Integer, K As Integer
On Error GoTo Err1
K = UBound(arrMyChar)
For I = 0 To K
If arrMyChar(I).Char = strChar Then
CheckHaveSameChar = True
Exit Function
End If
Next
CheckHaveSameChar = False
Exit Function
Err1:
CheckHaveSameChar = False
End Function
Private Sub Command1_Click()
Me.Text2.Text = SortString(Me.Text1.Text)
End Sub
northwolves 2004-08-08
- 打赏
- 举报
Option Explicit
Function trans(ByVal s As String) As String
Dim a() As String, tempstr As String, temp As Integer, i As Integer, j As Integer, k As Integer
i = 0
Do While Len(s) > 0
i = i + 1
ReDim Preserve a(1 To i)
tempstr = Left(s, 1)
temp = Len(s)
s = Replace(s, tempstr, "")
a(i) = String(temp - Len(s), tempstr)
tempstr = a(i)
If Len(tempstr) > Len(a(1)) Then
For k = i To 2 Step -1
a(k) = a(k - 1)
Next
a(1) = tempstr
Else
For j = 2 To i - 1
If Len(tempstr) < Len(a(j - 1)) And Len(a(i)) >= Len(a(j)) Then
For k = i To j + 1 Step -1
a(k) = a(k - 1)
Next
a(j) = tempstr
End If
Next
End If
Loop
trans = Join(a, "")
Erase a
End Function
Private Sub Form_Load()
Text1 = "aafacacddgd"
End Sub
Private Sub Command1_Click()
Text2 = trans(Text1)
End Sub
Function trans(ByVal s As String) As String
Dim a() As String, tempstr As String, temp As Integer, i As Integer, j As Integer, k As Integer
i = 0
Do While Len(s) > 0
i = i + 1
ReDim Preserve a(1 To i)
tempstr = Left(s, 1)
temp = Len(s)
s = Replace(s, tempstr, "")
a(i) = String(temp - Len(s), tempstr)
tempstr = a(i)
If Len(tempstr) > Len(a(1)) Then
For k = i To 2 Step -1
a(k) = a(k - 1)
Next
a(1) = tempstr
Else
For j = 2 To i - 1
If Len(tempstr) < Len(a(j - 1)) And Len(a(i)) >= Len(a(j)) Then
For k = i To j + 1 Step -1
a(k) = a(k - 1)
Next
a(j) = tempstr
End If
Next
End If
Loop
trans = Join(a, "")
Erase a
End Function
Private Sub Form_Load()
Text1 = "aafacacddgd"
End Sub
Private Sub Command1_Click()
Text2 = trans(Text1)
End Sub
海牛 2004-08-08
- 打赏
- 举报
与是否有别的字符无关吧，，，
skystar2001 2004-08-08
- 打赏
- 举报
问一下：只有26个英文字母吗??还有别的字符么??
ganfong 2004-08-08
- 打赏
- 举报
OK，行了。谢谢..
jtkkjtkk 2004-08-08
- 打赏
- 举报
不考虑有汉字的情况:
Private Sub Command1_Click()
Dim charsCnt(0 To 255) As Integer
Dim str As String
Dim ch As String
str = Text1.Text
Dim iLen As Integer
Dim iLoop As Integer
iLen = Len(str)
For iLoop = 1 To iLen
ch = Mid(str, iLoop, 1)
charsCnt(Asc(ch)) = charsCnt(Asc(ch)) + 1
Debug.Print ch; charsCnt(Asc(ch))
Next iLoop
str = ""
For iLoop = 1 To iLen
Dim maxCnt As Integer
Dim i As Integer, j As Integer
maxCnt = 0
For i = 0 To 255
If charsCnt(i) > maxCnt Then
maxCnt = charsCnt(i)
j = i
End If
Next i
charsCnt(j) = 0
str = str & String(maxCnt, Chr(j))
Next iLoop
Text1.Text = str
End Sub
Private Sub Command1_Click()
Dim charsCnt(0 To 255) As Integer
Dim str As String
Dim ch As String
str = Text1.Text
Dim iLen As Integer
Dim iLoop As Integer
iLen = Len(str)
For iLoop = 1 To iLen
ch = Mid(str, iLoop, 1)
charsCnt(Asc(ch)) = charsCnt(Asc(ch)) + 1
Debug.Print ch; charsCnt(Asc(ch))
Next iLoop
str = ""
For iLoop = 1 To iLen
Dim maxCnt As Integer
Dim i As Integer, j As Integer
maxCnt = 0
For i = 0 To 255
If charsCnt(i) > maxCnt Then
maxCnt = charsCnt(i)
j = i
End If
Next i
charsCnt(j) = 0
str = str & String(maxCnt, Chr(j))
Next iLoop
Text1.Text = str
End Sub
海牛 2004-08-08
- 打赏
- 举报
晕，，有点错误，，修改一下哦 Sorry······
Option Explicit
Private Type MyChar
Char As String
Count As Integer
End Type
'对字符串按要求的进行排序
Private Function SortString(ByVal strSource As String) As String
Dim I As Integer, K As Integer, M As Integer
Dim intLen As Integer, intTmp As Integer, intIndex As Integer
Dim strT As String, strResult As String
Dim arrMyChar() As MyChar, tMyCharTmp As MyChar
K = -1
ReDim arrMyChar(0) As MyChar
intLen = Len(strSource)
For I = 1 To intLen
strT = Mid(strSource, I, 1)
If CheckHaveSameChar(arrMyChar, strT, intIndex) = False Then
K = K + 1
ReDim Preserve arrMyChar(K) As MyChar
arrMyChar(K).Count = 1
arrMyChar(K).Char = strT
intIndex = K
Else
arrMyChar(intIndex).Count = arrMyChar(intIndex).Count + 1
End If
If K >= 0 Then
Me.Print arrMyChar(intIndex).Char & vbTab & arrMyChar(intIndex).Count
End If
Next
'对数组进行排序
K = UBound(arrMyChar)
For I = 0 To K - 1
intTmp = arrMyChar(I).Count
For M = I + 1 To K
If arrMyChar(M).Count > intTmp Then
tMyCharTmp = arrMyChar(I)
arrMyChar(I) = arrMyChar(M)
arrMyChar(M) = tMyCharTmp
intTmp = arrMyChar(I).Count
End If
Next
strResult = strResult & String(arrMyChar(I).Count, arrMyChar(I).Char)
Next
SortString = strResult & String(arrMyChar(K).Count, arrMyChar(K).Char)
End Function
'检查数组里面是否已经有了strChar字符
Private Function CheckHaveSameChar(arrMyChar() As MyChar, ByVal strChar As String, ByRef Index As Integer) As Boolean
Dim I As Integer, K As Integer
On Error GoTo Err1
K = UBound(arrMyChar)
For I = 0 To K
If arrMyChar(I).Char = strChar Then
CheckHaveSameChar = True
Index = I
Exit Function
End If
Next
CheckHaveSameChar = False
Exit Function
Err1:
CheckHaveSameChar = False
End Function
Private Sub Command1_Click()
Me.Text2.Text = SortString(Me.Text1.Text)
End Sub
Option Explicit
Private Type MyChar
Char As String
Count As Integer
End Type
'对字符串按要求的进行排序
Private Function SortString(ByVal strSource As String) As String
Dim I As Integer, K As Integer, M As Integer
Dim intLen As Integer, intTmp As Integer, intIndex As Integer
Dim strT As String, strResult As String
Dim arrMyChar() As MyChar, tMyCharTmp As MyChar
K = -1
ReDim arrMyChar(0) As MyChar
intLen = Len(strSource)
For I = 1 To intLen
strT = Mid(strSource, I, 1)
If CheckHaveSameChar(arrMyChar, strT, intIndex) = False Then
K = K + 1
ReDim Preserve arrMyChar(K) As MyChar
arrMyChar(K).Count = 1
arrMyChar(K).Char = strT
intIndex = K
Else
arrMyChar(intIndex).Count = arrMyChar(intIndex).Count + 1
End If
If K >= 0 Then
Me.Print arrMyChar(intIndex).Char & vbTab & arrMyChar(intIndex).Count
End If
Next
'对数组进行排序
K = UBound(arrMyChar)
For I = 0 To K - 1
intTmp = arrMyChar(I).Count
For M = I + 1 To K
If arrMyChar(M).Count > intTmp Then
tMyCharTmp = arrMyChar(I)
arrMyChar(I) = arrMyChar(M)
arrMyChar(M) = tMyCharTmp
intTmp = arrMyChar(I).Count
End If
Next
strResult = strResult & String(arrMyChar(I).Count, arrMyChar(I).Char)
Next
SortString = strResult & String(arrMyChar(K).Count, arrMyChar(K).Char)
End Function
'检查数组里面是否已经有了strChar字符
Private Function CheckHaveSameChar(arrMyChar() As MyChar, ByVal strChar As String, ByRef Index As Integer) As Boolean
Dim I As Integer, K As Integer
On Error GoTo Err1
K = UBound(arrMyChar)
For I = 0 To K
If arrMyChar(I).Char = strChar Then
CheckHaveSameChar = True
Index = I
Exit Function
End If
Next
CheckHaveSameChar = False
Exit Function
Err1:
CheckHaveSameChar = False
End Function
Private Sub Command1_Click()
Me.Text2.Text = SortString(Me.Text1.Text)
End Sub
