我需要您的幫助來構建一個宏，該宏可以從字串中提取日期（文本格式）并在不同的列中報告它們 - 比如說 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 與 B 3 FESX Mar22 @4090
OESX CNV 100 Dec23 4100 與 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
uj5u.com熱心網友回復：
簡單的原始答案：
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
應該在頂部函式中重新排列、排序和過濾重復項，您可以在此處更改日期輸出格式：
- “解析度（i）=格式（解析度（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轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/422027.html
標籤：
上一篇：如何模糊查詢一個串列？