Excel 根据单元格内容的位置重新排列单元格内容_Excel_Vba

Excel 根据单元格内容的位置重新排列单元格内容

excel vba

Excel 根据单元格内容的位置重新排列单元格内容,excel,vba,Excel,Vba,列A中的所有数据，每个单元格中的内容用逗号分隔。数字从1到4或1到1到5。我想从A列创建B列。 A2的内容为“4,1,2,3”。我必须以以下方式生成B2的内容：搜索A2中的数字1，其在单元格中的位置为2（第二个数字），因此B2中的第一个数字为2 然后搜索A2中的数字2，它的位置是3，因此B2中的第二个数字是3 等等。 B2的最终结果是：2,3,4,1 我对这些数组有点困惑。我遇到了Split和Join函数，所以我想使用它们。提前谢谢你的帮助。我的审判如下： Sub convert() Di

列A中的所有数据，每个单元格中的内容用逗号分隔。数字从1到4或1到1到5。我想从A列创建B列。 A2的内容为“4,1,2,3”。我必须以以下方式生成B2的内容：

搜索A2中的数字1，其在单元格中的位置为2（第二个数字），因此B2中的第一个数字为2

然后搜索A2中的数字2，它的位置是3，因此B2中的第二个数字是3

等等。 B2的最终结果是：2,3,4,1

我对这些数组有点困惑。我遇到了Split和Join函数，所以我想使用它们。提前谢谢你的帮助。我的审判如下：

Sub convert()
Dim i, j, k As Integer
Dim Oldtxt
Dim Newtxt As Variant
Dim Newcontent As String
lastrow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Oldtxt = Split(Cells(i, 1), ",")
For k = 1 To UBound(Oldtxt) + 1
For j = 1 To UBound(Oldtxt) + 1
If CInt(Oldtxt(k)) = j Then Newtxt(CInt(j)) = k
Next j
Next k
Newcontent = Join(Newtxt, ",")
Cells(i, 2) = Newcontent
Next i
End Sub

请测试下一个功能。我希望我终于明白你的意思：

Function DigitsPos(strInit As String) As String
 Dim arr, arrFin, i As Long, matchN As Long, k As Long

 arr = Split(strInit, ",")
 ReDim arrFin(UBound(arr))
 For i = 0 To UBound(arr)
    matchN = WorksheetFunction.Match(CStr(i + 1), arr, 0)
    arrFin(k) = matchN: k = k + 1
 Next i
 DigitsPos = Join(arrFin, ",")
End Function

可通过以下方式对其进行测试：

Sub testDitigsPos()
 Dim x As String
 x = "4,1,2,3"
 Debug.Print DigitsPos(x)
End Sub

或者使用下一个代码解决工作表中的问题：

Sub TestDigPosEvaluate()
 Dim sh As Worksheet, lastR As Long, i As Long
 
 Set sh = ActiveSheet 'use here your necessary sheet
 lastR = sh.range("A" & rows.count).End(xlUp).row
 For i = 2 To lastR
    sh.range("B" & i).Value = DigitsPos(sh.range("A" & i).Value)
 Next i
End Sub

匹配与循环

假设
```
OldTxt
```
数组始终包含
```
1
```
到
```
UBound（OldTxt）+1
```
之间的数字
第二，匹配解决方案，应该更有效

代码

Option Explicit

Sub convertLoop()
    
    With ThisWorkbook.Worksheets("Sheet1")
        
        Dim LastRow As Long
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        Dim OldTxt As Variant
        Dim NewTxt As Variant
        Dim NewContent As String
        Dim i As Long
        Dim j As Long
        Dim k As Long
        
        For i = 2 To LastRow
            OldTxt = Split(.Cells(i, 1), ",")
            ReDim NewTxt(0 To UBound(OldTxt))
            For j = 1 To UBound(OldTxt) + 1
                For k = 0 To UBound(OldTxt)
                    If CLng(OldTxt(k)) = j Then
                        NewTxt(j - 1) = CStr(k + 1)
                        Exit For
                    End If
                Next k
            Next j
            NewContent = Join(NewTxt, ",")
            .Cells(i, 2) = NewContent
        Next i
    
    End With

End Sub

Sub convertMatch()
    
    With ThisWorkbook.Worksheets("Sheet1")
        
        Dim LastRow As Long
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        Dim OldTxt As Variant
        Dim NewTxt As Variant
        Dim NewContent As String
        Dim i As Long
        Dim j As Long
        
        For i = 2 To LastRow
            OldTxt = Split(.Cells(i, 1), ",")
            ReDim NewTxt(0 To UBound(OldTxt))
            For j = 0 To UBound(OldTxt)
                NewTxt(j) = CStr(Application.Match(CStr(j + 1), OldTxt, 0))
            Next j
            NewContent = Join(NewTxt, ",")
            .Cells(i, 2) = NewContent
        Next i
    
    End With

End Sub

为了提高效率，可以将列范围复制到数组中，并在内存中修改数组，完成后将其复制到工作表中

Sub convertMatchTurbo()
    
    ' Define constants.
    Const wsName As String = "Sheet1"
    Const FirstRow As Long = 2
    Const srcCol As Long = 1
    Const dstCol As Long = 2
    ' Calculate Column Offset.
    Dim ColumnOffset As Long
    ColumnOffset = dstCol - srcCol
    ' Define Source Column Range.
    With ThisWorkbook.Worksheets(wsName)
        Dim LastRow As Long
        LastRow = .Cells(.Rows.Count, srcCol).End(xlUp).Row
        Dim rng As Range
        Set rng = .Columns(srcCol) _
          .Resize(LastRow - FirstRow + 1).Offset(FirstRow - 1)
    End With
    ' Write values from Source Column Range to Data Array.
    Dim Data As Variant
    Data = rng.Value
    ' Declare variables.
    Dim OldTxt As Variant
    Dim NewTxt As Variant
    Dim i As Long
    Dim j As Long
    ' Write resulting values to Data Array.
    For i = 1 To UBound(Data)
        OldTxt = Split(Data(i, 1), ",")
        ReDim NewTxt(0 To UBound(OldTxt))
        For j = 0 To UBound(OldTxt)
            NewTxt(j) = CStr(Application.Match(CStr(j + 1), OldTxt, 0))
        Next j
        Data(i, 1) = Join(NewTxt, ",")
    Next i
    ' Write values from Data Array to Destination Column Range.
    rng.Offset(, ColumnOffset).Value = Data

End Sub

通过一些更改，您可以创建一个函数来返回结果数组

Function CMT( _
    aWorksheet As Worksheet, _
    Optional ByVal FirstRowNumber As Long = 1, _
    Optional ByVal SourceColumnNumber As Long = 1, _
    Optional ByVal DestinationColumnnumber As Long = 1) _
As Variant

    ' Calculate Column Offset.
    Dim ColumnOffset As Long
    ColumnOffset = DestinationColumnnumber - SourceColumnNumber
    ' Define Source Column Range.
    With aWorksheet
        Dim LastRow As Long
        LastRow = .Cells(.Rows.Count, SourceColumnNumber).End(xlUp).Row
        Dim rng As Range
        Set rng = .Columns(SourceColumnNumber) _
          .Resize(LastRow - FirstRowNumber + 1).Offset(FirstRowNumber - 1)
    End With
    ' Write values from Source Column Range to Data Array.
    Dim Data As Variant
    Data = rng.Value
    ' Declare variables.
    Dim OldTxt As Variant
    Dim NewTxt As Variant
    Dim i As Long
    Dim j As Long
    ' Write resulting values to Data Array.
    For i = 1 To UBound(Data)
        OldTxt = Split(Data(i, 1), ",")
        ReDim NewTxt(0 To UBound(OldTxt))
        For j = 0 To UBound(OldTxt)
            NewTxt(j) = CStr(Application.Match(CStr(j + 1), OldTxt, 0))
        Next j
        Data(i, 1) = Join(NewTxt, ",")
    Next i
    ' Write result.
    CMT = Data

End Function

。。。然后像这样使用它：

Sub TestCMT()
    ' Define constants.
    Const wsName As String = "Sheet1"
    Const FirstRow As Long = 2
    Const srcCol As Long = 1
    Const dstCol As Long = 2
    ' Define worksheet.
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ' Define Data Array.
    Dim Data As Variant
    Data = CMT(ws, FirstRow, srcCol, dstCol)
    ' Write values from Data Array to Destination Column Range.
    ws.Cells(FirstRow, dstCol).Resize(UBound(Data, 1)).Value = Data
End Sub

算法

将数字分成两个数组
对其中一个数组排序
确定排序数组中每个值在未排序数组中的位置
以逗号分隔的字符串形式输出这些位置

我使用了

ArrayList

，因为它很容易排序：

Option Explicit
Function order(S As String) As String
    Dim AL1 As Object, AL2 As Object
    Dim v, w, x
    Dim I As Long
    
v = Split(S, ",")

Set AL1 = CreateObject("System.Collections.ArrayList")
For Each w In v
    AL1.Add w
Next w

Set AL2 = AL1.Clone
AL2.Sort

ReDim x(UBound(v))
I = 0
For Each w In AL2
    x(I) = AL1.indexof(w, 0) + 1
    I = I + 1
Next w

order = Join(x, ",")

End Function

请注意，上述例程是一个UDF（用户定义函数），因此公式

=订单（a2）

将输入B列的每个单元格中

如果您希望将其作为宏运行（数据位于a列），则可以使用此宏“调用”UDF。我们在VBA数组中执行此操作，因为它比重复读取/写入工作表快得多

Sub convertMatchTurbo()
    
    ' Define constants.
    Const wsName As String = "Sheet1"
    Const FirstRow As Long = 2
    Const srcCol As Long = 1
    Const dstCol As Long = 2
    ' Calculate Column Offset.
    Dim ColumnOffset As Long
    ColumnOffset = dstCol - srcCol
    ' Define Source Column Range.
    With ThisWorkbook.Worksheets(wsName)
        Dim LastRow As Long
        LastRow = .Cells(.Rows.Count, srcCol).End(xlUp).Row
        Dim rng As Range
        Set rng = .Columns(srcCol) _
          .Resize(LastRow - FirstRow + 1).Offset(FirstRow - 1)
    End With
    ' Write values from Source Column Range to Data Array.
    Dim Data As Variant
    Data = rng.Value
    ' Declare variables.
    Dim OldTxt As Variant
    Dim NewTxt As Variant
    Dim i As Long
    Dim j As Long
    ' Write resulting values to Data Array.
    For i = 1 To UBound(Data)
        OldTxt = Split(Data(i, 1), ",")
        ReDim NewTxt(0 To UBound(OldTxt))
        For j = 0 To UBound(OldTxt)
            NewTxt(j) = CStr(Application.Match(CStr(j + 1), OldTxt, 0))
        Next j
        Data(i, 1) = Join(NewTxt, ",")
    Next i
    ' Write values from Data Array to Destination Column Range.
    rng.Offset(, ColumnOffset).Value = Data

End Sub

因此，VBA模块将同时具有函数和子模块

Sub digitOrder()
    Dim vData As Variant
    Dim WS As Worksheet
    Dim I As Long, R As Range
    
Set WS = ThisWorkbook.Worksheets("sheet2")
With WS
    Set R = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp))
    vData = R
End With

For I = 2 To UBound(vData, 1)
    vData(I, 2) = order(CStr(vData(I, 1)))
Next I

With R
    .EntireColumn.Clear
    .Value = vData
End With
End Sub

主功能中无回路的进近

示例调用

```
[1]
```
将数据字符串分配给变量数组
```
[2]
```
通过main函数和
```
[3]
```
将数组写入B列

注意匹配数据中不可用的数字会导致不可用错误2042

由于OP，数据集中始终存在数字1..4，因此只要通过

执行检查即可，如果IsError（位置（5）），则…

Function GetDigitPositions(ByVal s As String) As String
    Dim data: data = Split(s, ",")                     ' e.g. 4|1|2|3  (without digit 5)
    Dim digits: digits = Split("1,2,3,4,5", ",")
    Dim pos: pos = Application.Match(digits, data, 0)
    If IsError(pos(5)) Then ReDim Preserve pos(1 To 4)
    GetDigitPositions = Join(pos, ",")                 ' e.g. "2,3,4,1" 
End Function

帮助函数

getData（）

试试这个

Sub convert()
Dim i As Long, k As Long
Dim Oldtxt as String
Dim Newtxt() As Variant
Dim Newcontent As String
    LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To LastRow
        Oldtxt = Split(Cells(i, 1), ",")
        ReDim Newtxt(UBound(Oldtxt))
        For k = 0 To UBound(Oldtxt)
            Newtxt(Oldtxt(k) - 1) = k + 1
        Next k
        Newcontent = Join(Newtxt, ",")
        Cells(i, 2) = Newcontent
    Next i
End Sub

由于@FaneDuru的评论，无环进近附录

简介

我试图回应@FaneDuru在2020-11-23评论中的评论，这可能会说明一些额外的，但有益的系统方面

由于我不想对我的原始答案收取过高的费用，我将此附录作为单独的答案发布。欢迎任何反馈

问答

“我在问自己，如果无法替换

数字=拆分（“1,2,3,4,5”，“，”）

使用一些评估行解决方案，…”

是的，这种灵活的评估是可能的，但需要一些补充

问题的关键主要不是数组的维数或基数，但是字符串是否与字符串进行比较

由于上述评估只返回数值，此灵活数字评估还必须包括一种字符串转换 为避免出现错误13类型不匹配（请参阅帮助功能►<代码>getDigits（））；这可以通过以下方式实现：

Evaluate("row(1:" & 5 & ") & """"")       ' add vbNullstring to the rows set

你说得对

“…即使我记得很清楚，

digits=Evaluate（“行（1:&UBound（数据）+1&”）

将返回一个2D数组。”

因此，您必须在

数字

数组上执行一个简单的

转置

，使其与

数据

数组相比较，即将其重新定尺寸为“平面”数组

“在其唯一列上对其进行切片并不复杂，但数组将基于1，我认为Match数组不会返回可行的结果。我不确定同样基于1的数据是否能解决问题。”

如上图所示，转置了

数字

，因此无需“摆弄”

数据

，即也无需修改

数据

数组

Application.Match（）的进一步特殊性

显然，它甚至接受两个不同的数组基作为参数。因此，您可以将基于1的

数字

数组作为第一个参数传递，将基于0的

数据

数组作为第二个参数传递，在任何情况下，只有生成的数组

pos

基于1

额外的

出于测试目的，

getDigits（）

help函数允许在基于零和基于一的结果之间进行选择

Function getDigits( _
                    ByVal n As Long, _
                    Optional ByVal IsLongType = True, _
                    Optional ZeroBased As Boolean = True)
    Dim digits
    If IsLongType Then
        digits = _
            Application.Transpose(Evaluate("row(1:" & n & ")"))        ' one  based
    Else
        digits = _
            Application.Transpose(Evaluate("row(1:" & n & ") & """"")) ' one  based
    End If
'    'redim digits base from 1-based to 0-based
    If ZeroBased Then ReDim Preserve digits(0 To n-1)          ' make it zero based
    'return digits
    getDigits = digits
End Function

主函数
GetDigitPositions（）
使用►<代码>getDigits（）

函数逻辑基于一种鲜为人知的可能性，即

Application.Match（）

，通过传递两个数组来返回一整套位置结果，从而避免循环：

Dim pos: pos = Application.Match(digits, data, 0)

Dim pos: pos = Application.Match(digits, data, 0)

附加帮助功能

freeofer2042（）

虽然不需要解决原始问题，但此函数可能会有所帮助使用

Join（）

函数。原因：单个错误2042项将阻止工作

Join

操作。可以检查这一点，因为

Count（）

忽略了错误项

Function FreeOfErr2042(arr) As Boolean
'Purpose: check if array includes Error 2042 items
'Note   : necessary to allow Join() function (if wanted)
    Dim totalItems As Long: totalItems = UBound(arr) - LBound(arr) + 1
    Dim validItems As Long: validItems = Application.Count(arr)
    If totalItems = validItems Then FreeOfErr2042 = True
End Function

（为了完整起见）

未更改的帮助函数

getData（）<
Function GetDigitPositions(ByVal s As String) As String
'Purpose: the relevant function with main logic to calculate resulting positions
    '[0] get data
    Dim data: data = Split(s, ",")                              ' zero based

    Dim digits                          ' zero|one-based possible
    '[1]>> ►getDigits()<< function instead of simple Split("1,2,3,4,5", ",")
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'a) get digits with an additional base change (argument ZeroBased:=True)
    'digits = getDigits(5, IsLongType:=False, ZeroBased:=True) ' zero based 
    'b) get one-based digits
    digits = getDigits(5, IsLongType:=False, ZeroBased:=False) ' one  based 
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '[2] Match allows different bases, but always results in a 1-based array
    Dim pos: pos = Application.Match(digits, data, 0)
    If IsError(pos(5)) Then ReDim Preserve pos(1 To 4)
    '[3] return results
    If FreeOfErr2042(pos) Then                  ' always true in this example
         GetDigitPositions = Join(pos, ",")
'    Else
'         Dim i As Long
'         For i = LBound(pos) To UBound(pos)
'            Debug.Print i, pos(i)
'         Next i
    End If
End Function

Function getDigits( _
                    ByVal n As Long, _
                    Optional ByVal IsLongType = True, _
                    Optional ZeroBased As Boolean = True)
    Dim digits
    If IsLongType Then
        digits = _
            Application.Transpose(Evaluate("row(1:" & n & ")"))        ' one  based
    Else
        digits = _
            Application.Transpose(Evaluate("row(1:" & n & ") & """"")) ' one  based
    End If
'    'redim digits base from 1-based to 0-based
    If ZeroBased Then ReDim Preserve digits(0 To n-1)          ' make it zero based
    'return digits
    getDigits = digits
End Function

Function FreeOfErr2042(arr) As Boolean
'Purpose: check if array includes Error 2042 items
'Note   : necessary to allow Join() function (if wanted)
    Dim totalItems As Long: totalItems = UBound(arr) - LBound(arr) + 1
    Dim validItems As Long: validItems = Application.Count(arr)
    If totalItems = validItems Then FreeOfErr2042 = True
End Function

Function getData(ws As Worksheet, Optional ByVal col = "A", Optional ByVal StartRow& = 2) As Variant()
    ' Purpose: assign column data to variant array
    If IsNumeric(col) Then col = Split(ws.Cells(1, col).Address, "$")(1)
    Dim lastRow As Long
    lastRow = ws.Range(col & Rows.Count).End(xlUp).Row
    getData = ws.Range(col & StartRow & ":" & col & lastRow).Value2
End Function


Sub ExampleCall()
    Dim v: v = getData(Sheet1, "A")                    ' << [1] assign data strings to variant array
    Dim i As Long
    For i = 1 To UBound(v)
        v(i, 1) = GetDigitPositions(v(i, 1))           ' << [2] main function finds positions 1..5
    Next i
    'write results                                     '    [3] write results
    Sheet1.Range("B2").Resize(UBound(v), 1) = v
End Sub

Function GetDigitPositions_(s As String) As String 
    Dim data: data = Split(s, ",")
    
    Dim digits: digits = Evaluate("row(1:" & UBound(data) + 1 & ") & """"")
    
    Dim pos: pos = Application.Transpose(Application.Match(digits, data, 0))
    GetDigitPositions_ = Join(pos, ",")
End Function

Sub testDitigsPos()
 Dim x As String
 x = "4,1,2,5,6,3"

 Debug.Print GetDigitPositions_(x)
End Sub