VBA打开多个工作簿，复制特定数据，删除重复的行并将信息粘贴到新工作簿中 [英] VBA to open several workbooks, copy specific data, remove duplicate rows and paste the information in a new workbook

问题描述

我知道标题不太清楚，但希望我可以在本说明中更好地解释它.我是VBA的新手，我需要编写一些执行以下操作的代码:

I know the title is not that clear but I hope I can explain it better in this description. I'm new to VBA and I need to write some code that does the following:

.在特定文件夹中打开几个工作簿，并将信息从源工作表(仅一个活动项)中间的表复制到新工作簿中的目标Sheet1.问题1:表具有相同的列数但行数不同(本来它们从A42到L ##(?)不同，因为用户可以添加或删除行，或将它们保留为空)，所以我要做的是创建一个新表每个源文件中都有一个隐藏的工作表，该工作表的第一个A列带有1和0，因此我可以知道复制范围并预格式化"我要传输到目标文件的信息)

. Opens several workbooks in a specific folder and copies information from a table in the middle of the source sheets (only one actives) to a target Sheet1 in a new workbook. Problem 1: the tables have the same number of columns but different number of rows (originally they vary from A42 to L##(?) because users can add or remove rows, or leave them blank) so what I did was create a new hidden sheet in each of the source files that has a first A column with 1s and 0s so I could know the range of my copy and "pre-format" the information I want to transfer to the target file)

.从目标工作簿的Sheet1的第二行(对于要复制的表)开始，将信息从每个源文件的隐藏工作表复制到目标工作簿-第一行将预先具有预写的标头-并继续粘贴目标工作表的第一个可用空白行中的下一个文件中的信息

. Copies the information from the hidden sheet of each source file to a target workbook, starting at the second row of Sheet1 of the target workbook (for the table being copied) - first row will have a pre-written header in advance - and keeps pasting information from the next files in the first available blank row of the target sheet

.删除重复的行:如果用户多次运行该宏，则不会看到原始表已重复多次(到目前为止还没有)

. Removes duplicate rows: in case the user runs the macro more than one time, won't see the original tables replicated several times (haven't got this far yet)

我对VBA知之甚少，所以这就是我在网上搜索粘贴复制不同内容的程度(顺便说一句，代码无法按预期工作):

I know very little about VBA so this is how far I've come copy-pasting different stuff I searched online (btw, code is not working as intended):

Sub ImportWorksheets()
Dim sFile As String           'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet

'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
  MsgBox "Specified folder does not exist, exiting!"
  Exit Sub
End If

'reset application settings in event of error
On Error GoTo errHandler
Application.ScreenUpdating = False

'set up the target worksheet
Set wsTarget = Sheets("Sheet1")

Dim NextRow0 As Long
NextRow0 = 2
'using NextRow0 to paste the new tables in in target sheet

'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""

  'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
  Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
  Set wsSource = wbSource.Worksheets(2) 'EDIT IF NECESSARY

  Dim lRow As Long

  lRow = wsSource.Columns("A").Find(1, SearchDirection:=xlPrevious, LookIn:=xlValues, LookAt:=xlWhole).Row
  wsSource.Range("B1:N" & lRow).Copy Destination:=wsTarget.Range("A" & NextRow0)
  NextRow0 = wsTarget.Range("A100000").End(xlUp).Row

  'close the source workbook, increment the output row and get the next file
  wbSource.Close SaveChanges:=False
  sFile = Dir()
Loop

errHandler:
On Error Resume Next
Application.ScreenUpdating = True


'tidy up
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
End Sub

现在，代码不是将信息粘贴为值，而是将路径粘贴，并且不复制正确的信息(第二列返回#REF).您能帮我弄清楚如何纠正错误并结束代码吗?

Right now the code is not pasting the information as values but rather paths and is not copying the right information (second column is returning #REF). Can you help me figure out how to correct what's wrong and end the code?

推荐答案

替换

  wsSource.Range("B1:N" & lRow).Copy Destination:=wsTarget.Range("A" & NextRow0)

使用

 wsSource.Range("B1:N" & lRow).Copy 
 wsTarget.Range("A" & NextRow0).pastespecial xlpastevalues

将您的数据从公式(即#REF)转换为值.假设您其余的代码都能正常工作

to turn your data from formulas (ie #REF) into values. Assuming the rest of your code works that ought to fix things

这篇关于VBA打开多个工作簿，复制特定数据，删除重复的行并将信息粘贴到新工作簿中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！