Question

我正在使用VBA程序，我想复制一定范围的单元格，然后将其粘贴到新的工作表中，标题是文本“ Delivery for”之后的字符串

例如我想复制“ Delivery for 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

选择并将特定字符串之后的单元格范围复制到另一个工作表

1 个答案: