查找文本值并将其移动到不同的列

Question

我需要您的帮助来构建一个宏，该宏可以从字符串中提取日期（文本格式）并在不同的列中报告它们 - 假设是 K 列，您能帮忙吗？

数据库下面的文字

合同

OESX BLT 100 Feb22 Mar22 4200 vs S 5 FESX Mar22 @4080

OESX P 100 Mar22 3050 与 6 FESX Mar22 @4080

OESX CDIA 100 Feb22 4300 Mar22 4400 vs B 3 FESX Mar22 @4090

OESX CNV 100 Dec23 4100 vs 100 FESX Mar22 @4100

OESX PBUT 2 月 22 日 3900 - 4000 - 4100

数据库列的长度不是固定的，每次都在变化。

最终目标是将日期放在合同的开头而不是中间。

提前谢谢你:)

代码：

Sub Macro8()

Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
Dim row
Dim column
Dim value

fndList = Array("Dec22 ", "Dec23 ")
rplcList = Array("", "")

Set sht = Sheets("Data")
  
****For Each cell In Range("A2:A40")
        If InStr(cell.Text, fndList) > 0 Then
            cell.Offset(0, 1).value = fndList
        End If
    Next cell****
  
  
For x = LBound(fndList) To UBound(fndList)
  
  sht.Cells.Replace What:=fndList(x), Replacement:=rplcList(x), _
          LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
          SearchFormat:=False, ReplaceFormat:=False

Next x

End Sub

Answer 1

简单的原始答案：

Function RearrangeContract(ref As String)
Dim I As Integer
Dim N As Integer
Dim Res As String
Dim Con As String
Con = ref
For I = 1 To Len(ref) - 3
    For N = 1 To 12
        If Mid(ref, I, 3) = Format(DateSerial(2021, N, 15), "mmm") Then
            Res = Res & Mid(ref, I, 5) & " "
            Con = Replace(Con, Mid(ref, I, 6), "")
        End If
    Next N
Next I
RearrangeContract = Res & Con
End Function

应该完全按照您的要求吐出字符串。 [在此处输入图片说明][1]

要么在自己的代码中使用该函数，要么将合同行导入 excel 并使用 =RearrangeContract() 作为 UDF

对于这样一个小任务，我们有一堆乱七八糟的代码，但我大约有 90% 的把握它会完美运行。

仅供参考：我走的是懒惰的排序路线，并从这里借了一个排序子：https://bettersolutions.com/vba/arrays/sorting-counting-sort.htm

应重新排列、排序和过滤重复项 在顶部函数中，您可以在此处更改日期输出格式：

• "Res(i) = 格式(Res(i), "mmmyy")"

Option Explicit
Option Base 0
Function RearrangeContractUnique(ref As String)
Dim i As Integer    'Character counter
Dim N As Integer    'Month counter
Dim Res()           'Result
Dim Con As String   'Contract - dates
Dim CNT As Integer  'Date found counter
Dim Temp
CNT = 0             'Counter to 0
Con = ref           'Store reference separately
For i = 1 To Len(ref) - 3   'Cycle through character in ref
    For N = 1 To 12         'Test each month againt section of ref
        If Mid(ref, i, 3) = Format(DateSerial(2021, N, 15), "mmm") Then
            CNT = CNT + 1   'Increment counter
            ReDim Preserve Res(1 To CNT)    'Resize array
            'Debug.Print Mid(ref, i + 3, 2)
            Res(CNT) = DateValue(DateSerial(20 & Mid(ref, i + 3, 2), N, 1))
            Con = Replace(Con, Mid(ref, i, 6), "")  'Remove date found from ref
        End If
    Next N
Next i
'Debug.Print "PreSort"
'For i = 1 To CNT
'Debug.Print Res(i)
'Next i
Array_CountingSort Res
'Debug.Print "PostSort"
'For i = 1 To CNT
'Debug.Print Res(i)
'Next i
'Reformat for output
For i = 1 To CNT
Res(i) = Format(Res(i), "mmmyy")
Next i
'Yeah, just shovel more worksheetfunctions into it.
RearrangeContractUnique = Join(Application.WorksheetFunction.Transpose _
(WorksheetFunction.Unique(Application.WorksheetFunction. _
Transpose(Res())))) & " " & Con
End Function
Public Sub Array_CountingSort(ByRef vArrayName As Variant)
Dim vCounting() As Long
Dim lLower As Long
Dim lUpper As Long
Dim larraymin As Long
Dim larraymax As Long
Dim i As Long
Dim j As Long
Dim lnextpos As Long
    larraymin = Helper_Minimum(vArrayName)
    larraymax = Helper_Maximum(vArrayName)
    lLower = LBound(vArrayName)
    lUpper = UBound(vArrayName)
    
    ReDim vCounting(larraymin To larraymax)
    For i = lLower To lUpper
        vCounting(vArrayName(i)) = vCounting(vArrayName(i)) + 1
    Next i

    lnextpos = lLower
    For i = larraymin To larraymax
        For j = 1 To vCounting(i)
            vArrayName(lnextpos) = i
            lnextpos = lnextpos + 1
        Next j
    Next i
End Sub
Public Function Helper_Maximum(ByVal vArrayName As Variant) As Long
Dim lmaxvalue As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim i As Long
    lrowlower = LBound(vArrayName)
    lrowupper = UBound(vArrayName)
    lmaxvalue = vArrayName(lrowlower)
    For i = lrowlower To lrowupper
        If (vArrayName(i) > lmaxvalue) Then
            lmaxvalue = vArrayName(i)
        End If
    Next i
    Helper_Maximum = lmaxvalue
End Function
Public Function Helper_Minimum(ByVal vArrayName As Variant) As Long
Dim lminvalue As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim i As Long
    lrowlower = LBound(vArrayName)
    lrowupper = UBound(vArrayName)
    lminvalue = vArrayName(lrowlower)
    For i = lrowlower To lrowupper
        If (vArrayName(i) < lminvalue) Then
            lminvalue = vArrayName(i)
        End If
    Next i
    Helper_Minimum = lminvalue
End Function