Question

我对VBA很新，有一项任务我想自动化，不知道从哪里开始。我有一个如下所示的数据集。

我要做的是循环到A列，如果它中有东西（将永远是一封电子邮件），请选择所有行，直到A列中再次出现。复制并粘贴到新标签页。因此，第2-5行将复制并粘贴到新选项卡中。然后将第6-9行放入另一个新选项卡中。第1行也会复制到每个标签。我无法找到代码来帮助满足这一特定需求，我们将非常感谢您的帮助。

我发现了这段代码，并开始对其进行修改，但是，它与我所需要的或者为此无关。

Sub split()

Dim rng As Range
Dim row As Range

Set rng = Range("A:A")

For Each row In rng
    'test if cell is empty
    If row.Value <> "" Then
        'write to adjacent cell
        row.Select
        row.Copy
        Worksheets("Sheet2").Activate
        Range("A2").Select
        row.PasteSpecial
        Worksheets("Sheet1").Activate
    End If
Next
End Sub

Answer 1

此代码应提供您所需的内容：

Sub Split()

Dim wb As Workbook
Set wb = ThisWorkbook

Dim ws As Worksheet
Set ws = wb.Worksheets(1) 'change sheet index or use Worksheets("Sheet1") method to use exact name

Dim rngBegin As Range
Dim rngEnd As Range

With ws

    Dim rngHeader As Range
    Set rngHeader = .Range("A1:H1") 'to copy headers over each time

    Dim lRowFinal As Long
    lRowFinal = .Range("C" & .Rows.Count).End(xlUp).Row 'assumes eventually last row of needed data will have an address1

    Set rngEnd = .Range("A1") ' to begin loop
    Set rngBegin = rngEnd.End(xlDown) 'to begin loop

    Do

        Set rngEnd = rngBegin.End(xlDown).Offset(-1)

        Dim wsNew As Worksheet
        Set wsNew = Worksheets.Add(After:=wb.Sheets(.Index))'always after current sheet, change as needed

        .Range(.Cells(rngBegin.Row, 1), .Cells(rngEnd.Row, 8)).Copy wsNew.Range("A2")
        wsNew.Range("A1:H1").Value = rngHeader.Value

        Set rngBegin = rngEnd.End(xlDown)

    Loop Until rngBegin.Row >= lRowFinal

End With

End Sub

Answer 2

尝试将您的流程分解为步骤并确定有关如何继续的规则。然后写出一些伪代码（类似逻辑的代码）以确保它们都有意义。

你需要某种循环，因为你要对待每一个循环一组行以同样的方式。
您需要一些代码来确定每个块中包含的单元格
采取阻止的代码（由步骤2给出）并将其粘贴到新选项卡中。

您的伪代码可能如下所示：

' This is the main function that runs the whole routine
Sub Main()

Set headerRg = GetHeaderRg()
Do Until IsAtTheEnd(startRow) = True
    Set oneBlock = GetNextBlock(startRow)
    Call ProcessBlock(oneBlock)
    startRow = startRow + oneBlock.Rows.Count

Loop

End Sub

' This function returns the header range to insert into the top
Function GetHeaderRg() As Range
    ' Write some code here that returns the header range
End Function

' This function determines whether we are at the end of our data
Function IsAtTheEnd(current_row as Long) as Boolean
    ' Write some code here that determines whether we have hit the end of our data 
    '(probably checks the first column to see if there is data)
End Function

' This function takes the startRow of a block and returns the whole block of Rows
Function GetNextBlock(startRow) As Range
    ' Write some code that returns the whole range you want to copy
End Function    


' This sub takes a range to be processed and a header to print and prints 
' it into a new tab
Sub ProcessBlock(BlockRg As Range, headerRg as Range)
    Set targetSheet = thisWorkbook.Sheets.Add()
    ' Write some code that pastes the headerRg and BlockRg where you want it
End Sub

如果您对语法等有更多具体问题，我们很乐意为您提供帮助！

在Excel中自动复制和粘贴特定范围的最佳方法是什么？

2 个答案: