VBA：清除剪贴板并在每个循环内重新填充

Question

设置

我的源 Excel 文件有 10k 行 32 列。我需要将其分解为 10 个文件，每个文件大小为 1k，并提取一个特定列 AD，以进行进一步处理。

AD 列是一个包含我需要保留的特殊字符的文本字符串，我正在尝试从过滤的字符串中删除不需要的双引号，以便稍后粘贴到另一个应用程序中。

问题陈述

仅第一个文件正确保存。第二个文件重复第一个循环中的信息，并使用第二个循环中过滤后的行更新它，第三个文件包含来自第一个、第二个和第三个循环的数据等。也就是说，当我们到达第 10 个时文件，我有 10k 行而不是 1k

问题

如何清除循环之间的剪贴板，以便清空 DataArray 和剪贴板，并使用该特定循环的过滤文本重新填充？

我的VBA是：

Sub SaveFiles()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("SourceData")
Dim Insert As Long
Dim Max_Ins As Long

Application.ScreenUpdating = False

Max_Ins = Application.WorksheetFunction.Max(ws.Range("AF:AF"))
ActiveSheet.Range("A:AF").AutoFilter Field:=27, Criteria1:="Ins"
    
For Insert = 1 To Max_Ins

ActiveSheet.Range("$AF:$AF").AutoFilter Field:=32, Criteria1:=Insert
      
    Range("AD1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy

    Workbooks.Add
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("1:1").Select
    Application.CutCopyMode = False  '** Trying to clear the clipboard**
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select

Dim DataArr() As Variant
Erase DataArr ' To clear the array each iteration
DataArr = Selection 'To repopulate the array with the current iteration


Dim objData As New DataObject
Dim concat As String
Dim cellValue As String
Dim i As Long
      
        For i = LBound(DataArr, 1) To UBound(DataArr, 1)
                      
        If IsNumeric(DataArr(i, 1)) Then
            cellValue = LTrim(Str(DataArr(i, 1)))
        Else
            cellValue = DataArr(i, 1)
        End If
        concat = concat + CR + cellValue
        CR = Chr(13)
        
        objData.SetText (Mid(concat, 3))
        objData.PutInClipboard
        
Next i
    
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select
    ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, _
    DisplayAsIcon:=False, NoHTMLFormatting:=True
      
    Range("A1").Select
    Selection.Delete Shift:=xlUp               '** I don't need the header rows on the saved files.**
        
      objData.SetText Text:=Empty              '** Trying to empty the objData set**
      objData.PutInClipboard       ** trying to insert the empty data back into the clipboard to clear it**
        
    ActiveWorkbook.SaveAs Filename:= _
        "Path" & ".xlsx" _
          , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close

Next
Insert = Insert + 1
End Sub

Answer 1

你可以尝试这样的事情：

Sub SaveFiles()
    Const BLOCK_SZ As Long = 1000 '# of values per block
    
    Dim ws As Worksheet, wb As Workbook, wsOut As Worksheet, v
    Dim data, block, r As Long, n As Long, ub As Long, blockNum As Long
    
    Set ws = ThisWorkbook.Sheets("SourceData")
    'pick up all data from Col AD
    data = ws.Range("AD2:AD" & ws.Cells(Rows.Count, "AD").End(xlUp).row).Value
    ub = UBound(data, 1) '# of rows
    
    Set wb = Workbooks.Add(xlWBATWorksheet) 'add single-sheet workbook
    Set wsOut = wb.Worksheets(1)
    
    n = 0
    blockNum = 0
    ReDim block(1 To BLOCK_SZ, 1 To 1) 'array for output
    For r = 1 To ub                    'loop over data and fill output array
        n = n + 1
        v = data(r, 1)
        If Not IsNumeric(v) Then
            block(n, 1) = v
        Else
            block(n, 1) = LTrim(Str(v))
        End If
        If n = BLOCK_SZ Or n = ub Then 'block is full, or end of data?
            blockNum = blockNum + 1    'increment block #
            wsOut.Range("A1").Resize(BLOCK_SZ).Value = block 'populate data block
            wb.SaveAs ThisWorkbook.Path & "\Block_" & blockNum & ".xlsx", _
                       FileFormat:=xlOpenXMLWorkbook
            ReDim block(1 To BLOCK_SZ, 1 To 1) 'clear output array
            n = 0                              'reset counter
        End If
    Next r
    wb.Close False
      
End Sub