Question

我有一些不连续的范围，每次运行时其大小可能会有所不同。我想采用每个范围，然后将其复制并粘贴到各自的工作表中（每张表一个范围）。

我的代码当前适用于第一个范围和表格。创建第二张图纸后，将突出显示范围，但是将再次复制第一个范围并将其粘贴到第二张图纸上，而不是粘贴到第二张图纸上。然后，创建了第三张纸，但是同样，只有第一个范围被复制并粘贴到该纸上。我知道循环有问题，但我不知道在哪里。

我已经用尽所有资源。我只是不知道为什么循环没有到达其他两个范围。

'Get current sheet name
Dim activeSheetName As String
activeSheetName = ActiveSheet.Name

'Create a new sheet to reformat existing data
Dim newSheetName As String
newSheetName = (activeSheetName + "_Data")

Dim filterRange As range
Dim areasCount As Integer
For Each a In filterRange.Areas
    Sheets(newSheetName).Select
    filterRange.Select
    range(Selection, Selection.End(xlToRight)).Select
    areasCount = Selection.Areas.Count
    With a
        For i = 2 To areasCount + 1
            Selection.Copy
            With Sheets.Add(After:=Sheets(Sheets.Count))
                .Name = a.Cells(1, 1).Value
                .range("A1").Value = a.Offset(, 1)
                range("A50").Select
                Selection.PasteSpecial paste:=xlPasteAll, Operation:=xlNone, _
                    SkipBlanks:= False, Transpose:=False
                Application.CutCopyMode = False
            End With
        Next i
    End With
Next a

我试图将我在书中找到的以下代码合并进来，但没有这种运气。

Dim SelAreas() As range
Dim pasteRange As range
Dim upperLeft As range
Dim numAreas As Long, i As Long
Dim topRow As Long, leftCol As Long
Dim rowOffset As Long, colOffset As Long

If TypeName(Selection) <> "Range" Then Exit Function

numAreas = Selection.Areas.Count
ReDim SelAreas(1 To numAreas)

For i = 1 To numAreas
    Set SelAreas(i) = Selection.Areas(i)
Next

topRow = ActiveSheet.Rows.Count
leftCol = ActiveSheet.Columns.Count

For i = 1 To numAreas
    If SelAreas(i).Row < topRow Then topRow = SelAreas(i).Row
    If SelAreas(i).Column < leftCol Then leftCol = SelAreas(i).Column
Next

Set upperLeft = Cells(topRow, leftCol)

On Error Resume Next
Set pasteRange = range("A50")
On Error GoTo 0

If TypeName(pasteRange) <> "Range" Then Exit Function

Set pasteRange = pasteRange.range("A1")

For i = 1 To numAreas
    rowOffset = SelAreas(i).Row - topRow
    colOffset = SelAreas(i).Column - leftCol
    SelAreas(i).Copy
    range("A1").Value = pasteRange.Offset(rowOffset, colOffset)
Next i

Answer 1

For Each a In filterRange.Areas

    Sheets(newSheetName).Select
    range(a, a.End(xlToRight)).Copy

    With a
    If filterRange Is Nothing Then
       MsgBox ("Value not present in this workbook.")
    Else
        With Sheets.Add(After:=Sheets(Sheets.Count))
             .Name = a.Cells(1, 1).Value
             .range("A1").Value = a.Offset(, 1)
             range("A50").Select
             ActiveSheet.paste
        End With
             range("A10:A49").Select
             range(Selection, Selection.End(xlToRight)).Select
             Selection.Delete
             range("A1").Select
    End If
    End With
Next a

正确遍历非连续范围？

1 个答案: