清除剪贴板并在每个循环中重新填充

huangapple go评论169阅读模式
英文:

VBA: Clear Clipboard and Repopulate Within Each Loop

问题

设置

我的源Excel文件有10,000行32列。我需要将其拆分为10个包含1,000行的文件,并提取一列AD,以便进行进一步处理。

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

问题陈述

只有第一个文件保存正确。第二个文件重复了第一个循环中的信息,并将其更新为第二个循环中的过滤行,第三个文件包含来自第一个、第二个和第三个循环的数据,依此类推。也就是说,当我们到达第10个文件时,我有10,000行而不是1,000行。

问题

如何在循环之间清除剪贴板,以便同时清空DataArray和剪贴板,并重新填充该特定循环的过滤文本?

我的(带有解释的)VBA代码如下:

  1. Sub SaveFiles()
  2. '声明变量
  3. Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("SourceData")
  4. Dim Insert As Long, Max_Ins As Long, i As Long
  5. Dim DataArr() As Variant
  6. Dim objData As New DataObject
  7. Dim concat As String, cellValue As String
  8. '开始筛选源数据表以定位所需行
  9. Max_Ins = Application.WorksheetFunction.Max(ws.Range("AF:AF"))
  10. ActiveSheet.Range("A:AF").AutoFilter Field:=27, Criteria1:="Ins"
  11. For Insert = 1 To Max_Ins
  12. ' "Insert"是源表上的一个单元格,将行2到1000分配为1,1001到2000分配为2等。
  13. ActiveSheet.Range("$AF:$AF").AutoFilter Field:=32, Criteria1:=Insert
  14. ' 我只需要处理列AD
  15. Range("AD1").Select
  16. Range(Selection, Selection.End(xlDown)).Select
  17. Selection.SpecialCells(xlCellTypeVisible).Select
  18. Selection.Copy
  19. ' 我需要在新工作簿中保存数据
  20. Workbooks.Add
  21. Range("A1").Select
  22. Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  23. :=False, Transpose:=False
  24. Rows("1:1").Select
  25. Application.CutCopyMode = False
  26. Range("A1").Select
  27. Range(Selection, Selection.End(xlDown)).Select
  28. '现在我有了我的“小文件”,我想将数据加载到数组中进行处理。
  29. Erase DataArr
  30. DataArr = Selection
  31. '我在另一篇帖子中找到了这个,它成功地从数据中删除了双引号,以便稍后可以正确复制/粘贴。
  32. For i = LBound(DataArr, 1) To UBound(DataArr, 1)
  33. If IsNumeric(DataArr(i, 1)) Then
  34. cellValue = LTrim(Str(DataArr(i, 1)))
  35. Else
  36. cellValue = DataArr(i, 1)
  37. End If
  38. concat = concat & vbCrLf & cellValue
  39. objData.SetText Mid(concat, 3)
  40. objData.PutInClipboard
  41. Next i
  42. '现在我的文本已经按我需要的方式处理了,我试图将其粘贴回工作簿。
  43. '首先删除现有数据(现在在数组中,并已被清理)
  44. Range("A1").Select
  45. Range(Selection, Selection.End(xlDown)).Select
  46. Selection.ClearContents
  47. '然后粘贴回objData清理后的值
  48. Range("A1").Select
  49. ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, _
  50. DisplayAsIcon:=False, NoHTMLFormatting:=True
  51. '我不需要最终文件中的标题行,但似乎有必要处理它,因为没有它,第一行通常只有3个字符
  52. Range("A1").Select
  53. Selection.Delete Shift:=xlUp
  54. '尝试在objdata准备好下一次循环之前清除剪贴板。
  55. '这是我需要帮助的部分,因为它不起作用,所以第二个循环保留了第一个循环的数据,然后添加了第二个,第三个包含1、2,然后添加3等等。
  56. objData.SetText Empty
  57. objData.PutInClipboard
  58. '保存文件
  59. ActiveWorkbook.SaveAs Filename:= _
  60. "C:\Users\...\ " & Format(Date, "YYYYMMDD") & "_" & Format(Time, "hhmmss") & "Insert" & "_" & Insert & ".xlsx" _
  61. , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  62. ActiveWorkbook.Close
  63. Next
  64. MsgBox "文件已保存"
  65. End Sub
英文:

Setup

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

Question

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:

  1. Sub SaveFiles()
  2. 'Declarations
  3. Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("SourceData")
  4. Dim Insert As Long, Max_Ins As Long, i As Long
  5. Dim DataArr() As Variant
  6. Dim objData As New DataObject
  7. Dim concat As String, cellValue As String
  8. 'begin filtering Source Data Sheet to target required rows
  9. Max_Ins = Application.WorksheetFunction.Max(ws.Range("AF:AF"))
  10. ActiveSheet.Range("A:AF").AutoFilter Field:=27, Criteria1:="Ins"
  11. For Insert = 1 To Max_Ins
  12. ' "Insert" is a cell on the Source Sheet which assigns rows 2 to 1000 as 1, 1001 to 2000 as 2 etc.
  13. ActiveSheet.Range("$AF:$AF").AutoFilter Field:=32, Criteria1:=Insert
  14. ' I only need to process column AD for this exercise
  15. Range("AD1").Select
  16. Range(Selection, Selection.End(xlDown)).Select
  17. Selection.SpecialCells(xlCellTypeVisible).Select
  18. Selection.Copy
  19. ' I need the data in a new workbook
  20. Workbooks.Add
  21. Range("A1").Select
  22. Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  23. :=False, Transpose:=False
  24. Rows("1:1").Select
  25. Application.CutCopyMode = False
  26. Range("A1").Select
  27. Range(Selection, Selection.End(xlDown)).Select
  28. 'now I have my 'mini file' created I want to load the data into an array for processing.
  29. Erase DataArr
  30. DataArr = Selection
  31. ' 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.
  32. For i = LBound(DataArr, 1) To UBound(DataArr, 1)
  33. If IsNumeric(DataArr(i, 1)) Then
  34. cellValue = LTrim(Str(DataArr(i, 1)))
  35. Else
  36. cellValue = DataArr(i, 1)
  37. End If
  38. concat = concat + CR + cellValue
  39. CR = Chr(13)
  40. objData.SetText (Mid(concat, 3))
  41. objData.PutInClipboard
  42. Next i
  43. 'Now my text is as I need it, i'm trying to paste it back into the workbook.
  44. 'I start by removing the existing data (which is now in the array, and has been cleansed)
  45. Range("A1").Select
  46. Range(Selection, Selection.End(xlDown)).Select
  47. Selection.ClearContents
  48. 'then paste back the objData cleansed values
  49. Range("A1").Select
  50. ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, _
  51. DisplayAsIcon:=False, NoHTMLFormatting:=True
  52. '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
  53. Range("A1").Select
  54. Selection.Delete Shift:=xlUp
  55. 'Attempting to clear the Clipboard in objdata ready for the next loop.
  56. '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.
  57. objData.SetText Text:=Empty
  58. objData.PutInClipboard
  59. 'saving down the files
  60. ActiveWorkbook.SaveAs Filename:= _
  61. "C:\Users\...\" & Format(Date, "YYYYMMDD") & "_" & Format(Time, "hhmmss") & "Insert" & "_" & Insert & ".xlsx" _
  62. , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  63. ActiveWorkbook.Close
  64. Next
  65. MsgBox ("Files saved")
  66. End Sub

答案1

得分: 0

您可以尝试类似这样的代码:

  1. Sub SaveFiles()
  2. Const BLOCK_SZ As Long = 1000 '每个块的值数量
  3. Dim ws As Worksheet, wb As Workbook, wsOut As Worksheet, v
  4. Dim data, block, r As Long, n As Long, ub As Long, blockNum As Long
  5. Set ws = ThisWorkbook.Sheets("SourceData")
  6. '从列AD中获取所有数据
  7. data = ws.Range("AD2:AD" & ws.Cells(Rows.Count, "AD").End(xlUp).Row).Value
  8. ub = UBound(data, 1) '行数
  9. Set wb = Workbooks.Add(xlWBATWorksheet) '添加包含单个工作表的工作簿
  10. Set wsOut = wb.Worksheets(1)
  11. n = 0
  12. blockNum = 0
  13. ReDim block(1 To BLOCK_SZ, 1 To 1) '用于输出的数组
  14. For r = 1 To ub '循环遍历数据并填充输出数组
  15. n = n + 1
  16. v = data(r, 1)
  17. If Not IsNumeric(v) Then
  18. block(n, 1) = v
  19. Else
  20. block(n, 1) = LTrim(Str(v))
  21. End If
  22. If n = BLOCK_SZ Or n = ub Then '块已满或数据结束?
  23. blockNum = blockNum + 1 '增加块编号
  24. wsOut.Range("A1").Resize(BLOCK_SZ).Value = block '填充数据块
  25. wb.SaveAs ThisWorkbook.Path & "\Block_" & blockNum & ".xlsx", _
  26. FileFormat:=xlOpenXMLWorkbook
  27. ReDim block(1 To BLOCK_SZ, 1 To 1) '清空输出数组
  28. n = 0 '重置计数器
  29. End If
  30. Next r
  31. wb.Close False
  32. End Sub
英文:

You could try something like this:

  1. Sub SaveFiles()
  2. Const BLOCK_SZ As Long = 1000 '# of values per block
  3. Dim ws As Worksheet, wb As Workbook, wsOut As Worksheet, v
  4. Dim data, block, r As Long, n As Long, ub As Long, blockNum As Long
  5. Set ws = ThisWorkbook.Sheets("SourceData")
  6. 'pick up all data from Col AD
  7. data = ws.Range("AD2:AD" & ws.Cells(Rows.Count, "AD").End(xlUp).row).Value
  8. ub = UBound(data, 1) '# of rows
  9. Set wb = Workbooks.Add(xlWBATWorksheet) 'add single-sheet workbook
  10. Set wsOut = wb.Worksheets(1)
  11. n = 0
  12. blockNum = 0
  13. ReDim block(1 To BLOCK_SZ, 1 To 1) 'array for output
  14. For r = 1 To ub 'loop over data and fill output array
  15. n = n + 1
  16. v = data(r, 1)
  17. If Not IsNumeric(v) Then
  18. block(n, 1) = v
  19. Else
  20. block(n, 1) = LTrim(Str(v))
  21. End If
  22. If n = BLOCK_SZ Or n = ub Then 'block is full, or end of data?
  23. blockNum = blockNum + 1 'increment block #
  24. wsOut.Range("A1").Resize(BLOCK_SZ).Value = block 'populate data block
  25. wb.SaveAs ThisWorkbook.Path & "\Block_" & blockNum & ".xlsx", _
  26. FileFormat:=xlOpenXMLWorkbook
  27. ReDim block(1 To BLOCK_SZ, 1 To 1) 'clear output array
  28. n = 0 'reset counter
  29. End If
  30. Next r
  31. wb.Close False
  32. End Sub

huangapple
  • 本文由 发表于 2023年8月11日 01:39:15
  • 转载请务必保留本文链接:https://go.coder-hub.com/76878120.html
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定