選擇特定字符串后的單元格范圍並將其復制到另一個工作表

Question

我正在運行一個 VBA 程序，我想復制一系列單元格，然后將其粘貼到新的工作表中，標題是文本“Delivery for”之后的字符串

例如，我想復制“Delivery for Sam”下的范圍，新工作表的名稱應為“Sam”

Dim N as long
N = Range(Cells(rcell, Col_Western).End(xlDown).Row)

With ActiveSheet
    For rcell = 1 To lastrow
        If InStr(1, Cells(rcell, Col_Western), "Delivery for", vbBinaryCompare) > 0 Then
            Range(ActiveCell & N).Select
            Selection.Copy After:=Worksheets(Sheets.Count)
            ActiveSheet.Name = "QBS"
        End If
    Next rcell
End With

Answer 1

未經測試，寫在手機上。 可能有效，也可能無效，但可能會給你一些關於如何實現它的想法。

Option Explicit

Sub test()

Dim sourceSheet as worksheet
'Change this to the name of the sheet which contains the data you want to separate by name. I assume Sheet1'
Set sourceSheet = Thisworkbook.worksheets("Sheet1")

With sourceSheet

Dim westernColumn as long
' If this can change (based on the location of the data), you need to work out some logic to assign it dynamically. If this does not change, turn it into a constant and assign to whatever column number it should be. I arbitrarily pick column 5 (column E) as an example '
westernColumn = 5

Dim lastRow as long
lastRow = .cells(.rows.count, westernColumn).end(xlup).row

End with

Dim rowIndex as long
Dim deliveryName as string
Dim characterIndex as long

For rowIndex = 1 to lastRow

characterIndex = InStr(1, sourcesheet.Cells(rowIndex, westernColumn).value2, "Delivery for ", vbBinaryCompare)

If characterIndex > 0 Then

deliveryName = VBA.strings.mid$(sourcesheet.Cells(rowIndex, westernColumn).value2, characterindex + 13) '+13 is a magic number used to exclude "Delivery for " string itself, implement it in a better way if possible'

With thisworkbook.worksheets.add
' this line below might cause an error if a sheet with this name already exists or if deliveryName is illegal in some way. Maybe code some defensive checks before assigning sheet name.
.name = deliveryName

' This includes the "Delivery for " row when copy-pasting  and assumes each there is a blank row before each "Delivery for " row. '
sourceSheet.range(sourcesheet.Cells(rowIndex, westernColumn), sourcesheet.Cells(rowIndex, westernColumn).end(xldown)).copy .range("A1")

End with

End if

' you should probably have two variables: startRow and endRow, where startRow = first "Delivery for ", and endRow = next "Delivery for "

' but I don't have time to do this at the moment.'

Next rowIndex ' should increment rowIndex by number of rows pasted - 1, so that pasted rows are not needlessly checked for "Delivery for " string '

End sub