VBA: Clear Clipboard and Repopulate Within Each Loop


My source Excel file has 10k rows of 32 columns. I need to break this down into 10 files of 1k each and extract one specific column, AD, for further processing.

Column AD is is a text string containing special characters which I need to preserve, and I'm trying to remove the unwanted double quotes from the filtered string for pasting into another application later.

Problem Statement

Only the first file is saving correctly. The second file repeats the information from the first loop as well as updating it with the filtered rows from the second loop, the third file contains data from the first, second and third loops etc. That is, by the time we get to the 10th file, I have 10k rows instead of 1k


How do I clear the clipboard between loops so that both the DataArray and the Clipboard are emptied, and refilled afresh with the filtered text for that specific loop?

My (edited with explanations) VBA is:

Sub SaveFiles()


Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("SourceData")
Dim Insert As Long, Max_Ins As Long, i As Long
Dim DataArr() As Variant
Dim objData As New DataObject
Dim concat As String, cellValue As String

'begin filtering Source Data Sheet to target required rows
Max_Ins = Application.WorksheetFunction.Max(ws.Range("AF:AF"))
ActiveSheet.Range("A:AF").AutoFilter Field:=27, Criteria1:="Ins"
For Insert = 1 To Max_Ins
           ' "Insert" is a cell on the Source Sheet which assigns rows 2 to 1000 as 1, 1001 to 2000 as 2 etc.
            ActiveSheet.Range("$AF:$AF").AutoFilter Field:=32, Criteria1:=Insert
           ' I only need to process column AD for this exercise
            Range(Selection, Selection.End(xlDown)).Select

' I need the data in a new workbook
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range(Selection, Selection.End(xlDown)).Select

'now I have my 'mini file' created I want to load the data into an array for processing.
Erase DataArr
DataArr = Selection

' I found this in another post, and it's successfully removing the double quotes from the data so I can then copy/paste it correctly later.
        For i = LBound(DataArr, 1) To UBound(DataArr, 1)
                         If IsNumeric(DataArr(i, 1)) Then
                            cellValue = LTrim(Str(DataArr(i, 1)))
                            cellValue = DataArr(i, 1)
                        End If
                        concat = concat + CR + cellValue
                        CR = Chr(13)
                        objData.SetText (Mid(concat, 3))
        Next i
'Now my text is as I need it, i'm trying to paste it back into the workbook.
'I start by removing the existing data (which is now in the array, and has been cleansed)
    Range(Selection, Selection.End(xlDown)).Select
'then paste back the objData cleansed values
    ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, _
    DisplayAsIcon:=False, NoHTMLFormatting:=True
'I don't need the header row in my final files but it seems good to have it processed as, without it, the first line is usually 3 chara
    Selection.Delete Shift:=xlUp
'Attempting to clear the Clipboard in objdata ready for the next loop.
'This is the part which I need help with as it's not working and so the 2nd loop retains the data from the first loop and then adds the 2nd, the 3rd contains 1,2 and then adds 3 etc.
objData.SetText Text:=Empty
'saving down the files
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\...\" & Format(Date, "YYYYMMDD") & "_" & Format(Time, "hhmmss") & "Insert" & "_" & Insert & ".xlsx" _
          , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False


MsgBox ("Files saved")

End Sub


  • You could try something like this:

    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
                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", _
                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