Question

所以我有VBA代码来执行此操作：

从工作表中复制＆＃34; Sheet1＆＃34; A1栏：L1001
将它们粘贴到工作表中＆＃34;粘贴＆＃34;
清洁细胞（某些细胞有＆＃34;＆＃34;在其中）
删除所有空白行
复制来自＆＃34;粘贴＆＃34;的数据A1：L1001
在指定位置创建新工作簿，使用日期戳重命名工作表，粘贴来自＆＃34;粘贴＆＃34;工作表并保存工作表

现在我想在4-5步之间添加另一个步骤： 4A。计数列A：A并且如果A：A> 100行然后拆分成另一个工作簿并使用[date_stamp] _2或其他任何内容保存它。

因此，如果工作簿包含340行，则将有4个工作簿1-100行101-200,201-300和301-340行。

任何想法？

如计数A：A，如果A：A> 100，则取A1：L100，然后从A101计数：A1001如果＆gt; 100然后A1（标题）A101：L200 ......

＆＃39; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

'~~> Copy A Range of Data
    Worksheets("OPT_REPORT").Range("A1:M1001").SpecialCells(xlCellTypeVisible).Copy

'~~> PasteSpecial Values Only
    Worksheets("paste").Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

'~~> Clear Clipboard
    Application.CutCopyMode = False

＆＃39; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

'~~> Find "" and replace with pneumonoultramicroscopicsilicovolcanoconiosis

    Worksheets("paste").Range("A1:M1001").Cells.Replace What:="", Replacement:="pneumonoultramicroscopicsilicovolcanoconiosis", LookAt:= _
    xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

'~~> Find pneumonoultramicroscopicsilicovolcanoconiosis and replace with ""

    Worksheets("paste").Range("A1:M1001").Cells.Replace What:="pneumonoultramicroscopicsilicovolcanoconiosis", Replacement:="", LookAt:= _
    xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

＆＃39; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

'~~> Finds a space in column A and deletes entire row

    On Error Resume Next
    Worksheets("paste").Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

＆＃39; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Dim wbI As Workbook, wbO As Workbook
    Dim wsI As Worksheet, wsO As Worksheet
    Date1 = Now()

'~~> Source/Input Workbook

    Set wbI = ThisWorkbook

'~~> Set the relevant sheet from where you want to copy

    Set wsI = wbI.Sheets("paste")

'~~> Destination/Output Workbook

    Set wbO = Workbooks.Add

With wbO
    '~~> Set the relevant sheet to where you want to paste
    Set wsO = wbO.Sheets("Sheet1")

    '~~>. Save the file
    .SaveAs Filename:="C:\FILES\Test_" & Format(Date1, "ddmmyyyy-hhmmss") & ".xls", FileFormat:=56

    '~~> Copy the range
    wsI.Range("A1:M1001").SpecialCells(xlCellTypeVisible).Copy

    '~~> Paste it in say Cell A1. Change as applicable
    wsO.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, _
    SkipBlanks:=True, Transpose:=False

＆＃39; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Workbooks("Test_" & Format(Date1, "ddmmyyyy-hhmmss") & ".xls").Close SaveChanges:=True

＆＃39; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Sheets("paste").Range("A1:M1001").Clear

＆＃39; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    MsgBox "File Saved"

＆＃39; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Answer 1

如果我是你，我会检查第101个细胞是否有数据，然后是第201个细胞...... 假设A列始终是数据，直到最后一行，您可以像下面的代码一样：

Dim row as integer: row = 1
Do while NOT IsEmpty(Sheet("paste").cells(row,1))
    'Here goes the code from steps 5 to 6, saving the cells: "A" & row & ":L" & row+99
    'ex.: A1:L100, A101:L200, and so on...
    row = row +100
Loop

VBA宏拆分工作表

1 个答案: