[英]Search for specific column header, copy column and paste to another workbook
[英]Search for column header, copy column and paste to master workbook
我如何复制具有这些列标题名称“ TOOL CUTTER”和“ HOLDER”的列(仅数据),并将它们(作为追加内容添加到同一列标题名称中的每个列中),粘贴到另一个工作簿工作表中,其中VBA代码(工作表模块)是。 谢谢。 列标题HOLDER出现在F10中(最好写为(10,6),TOOL CUTTER出现在G10(10,11)中),但最好让它搜索标题名称并打印该列中的内容,直到完全是空的(可能会出现空格)。非常感谢您的帮助!
工作代码:循环打开文件夹中的文件–打开文件,将文件名打印到Masterfile表中,将项目J1从文件打印到Masterfile表中,关闭文件,打开文件夹中的下一个文件,直到所有文件都被遍历为止。
Option Explicit
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim Sht As Worksheet, ws As Worksheet
Dim WB As Workbook
Dim i As Integer
Dim LastRow As Integer, erow As Integer
Dim Height As Integer
Application.ScreenUpdating = False
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set Sht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'print file name
Workbooks.Open Filename:=MyFolder & objFile.Name
Set WB = ActiveWorkbook
With WB
For Each ws In .Worksheets
Sht.Cells(i + 1, 1) = objFile.Name
With ws
.Range("J1").Copy Sht.Cells(i + 1, 4)
End With
i = i + 1
Next ws
.Close SaveChanges:=False
End With
End If
Next objFile
Application.ScreenUpdating = True
End Sub
我正在尝试尝试打印HOLDER和TOOL CUTTER列中的值的代码(返回错误For Each Tool In TOOLList
的块中, For Each Tool In TOOLList
中的For Each Tool In TOOLList
行中未定义Tool变量,将其粘贴到找到的工具列表中)此表:
Option Explicit
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim StartSht As Worksheet, ws As Worksheet
Dim WB As Workbook
Dim i As Integer
Dim LastRow As Integer, erow As Integer
Dim Height As Integer
'Application.ScreenUpdating = False
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set StartSht = ActiveSheet
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 2
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'print file name
StartSht.Cells(i, 1) = objFile.Name
Dim NewWb As Workbook
Set NewWb = Workbooks.Open(Filename:=MyFolder & objFile.Name)
'print TDS values
With WB
For Each ws In .Worksheets
StartSht.Cells(i + 1, 1) = objFile.Name
With ws
.Range("J1").Copy StartSht.Cells(i + 1, 4)
End With
i = i + 1
Next ws
.Close SaveChanges:=False
End With
End If
'print CUTTING TOOL and HOLDER lists
Dim k As Long
Dim width As Long
Dim TOOLList As Object
Dim count As Long
Set TOOLList = CreateObject("Scripting.Dictionary")
Dim ToolRow As Integer 'set as As Long if more than 32767 rows
' search for all on other sheets
' Assuming header means Row 1
If objFile.Name <> "masterfile.xls" Then 'skip any processing on "Masterfile.xls"
For Each ws In NewWb.Worksheets 'assuming we want to look through the new workbook
With ws
width = .Cells(10, .Columns.count).End(xlToLeft).Column
For k = 1 To width
If Trim(.Cells(10, k).Value) = "CUTTING TOOL" Then
Height = .Cells(.Rows.count, k).End(xlUp).Row
If Height > 1 Then
For ToolRow = 2 To Height
If Not TOOLList.exists(.Cells(ToolRow, k).Value) Then
TOOLList.Add .Cells(ToolRow, k).Value, ""
End If
Next ToolRow
End If
End If
Next
End With
Next
End If
' paste the TOOL list found back to this sheet
With StartSht
width = .Cells(10, .Columns.count).End(xlToLeft).Column
For k = 1 To width
If Trim(.Cells(10, k).Value) = "CUTTING TOOL" Then
Height = .Cells(.Rows.count, k).End(xlUp).Row
count = 0
For Each Tool In TOOLList
count = count + 1
.Cells(Height + count, k).Value = Tool
Next
End If
Next
End With
'close current file, do not save changes
NewWb.Close SaveChanges:=False
i = i + 1
'move to next file
Next objFile
'Application.ScreenUpdating = True
End Sub
将一些截然不同的任务重构为单独的功能可以使您的代码更整洁,更易于遵循。
编译但未经测试:
Option Explicit
Sub LoopThroughDirectory()
Const SRC_FOLDER As String = "C:\Users\trembos\Documents\TDS\progress\"
Const ROW_HEADER As Long = 10
Dim f As String
Dim StartSht As Worksheet, ws As Worksheet
Dim WB As Workbook
Dim i As Integer
Dim dict As Object
Dim hc As Range, hc2 As Range, d As Range
Set StartSht = ActiveSheet
i = 3
f = Dir(SRC_FOLDER & "*.xls*", vbNormal) 'get first file name
'find the header on the master sheet
Set hc2 = HeaderCell(StartSht.Cells(ROW_HEADER, 1), "CUTTING TOOL")
If hc2 Is Nothing Then
MsgBox "No header found on master sheet!"
Exit Sub
End If
'loop through directory file and print names
Do While Len(f) > 0
If f <> ThisWorkbook.Name Then
Set WB = Workbooks.Open(SRC_FOLDER & f)
For Each ws In WB.Worksheets
StartSht.Cells(i, 1) = f
ws.Range("J1").Copy StartSht.Cells(i, 4)
i = i + 1
'find the header on the source sheet
Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
If Not hc Is Nothing Then
Set dict = GetUniques(hc.Offset(1, 0))
If dict.count > 0 Then
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
'add the values to the master list
d.Resize(dict.count, 1).Value = Application.Transpose(dict.keys)
End If
Else
'header not found on source worksheet
End If
Next ws
WB.Close savechanges:=False
End If 'not the master file
f = Dir() 'next file
Loop
End Sub
'get all unique column values starting at cell c
Function GetUniques(ch As Range) As Object
Dim dict As Object, rng As Range, c As Range, v
Set dict = CreateObject("scripting.dictionary")
For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
v = Trim(c.Value)
If Len(v) > 0 And Not dict.exists(v) Then
dict.Add v, ""
End If
Next c
Set GetUniques = dict
End Function
'find a header on a row: returns Nothing if not found
Function HeaderCell(rng As Range, sHeader As String) As Range
Dim rv As Range, c As Range
For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells
If Trim(c.Value) = sHeader Then
Set rv = c
Exit For
End If
Next c
Set HeaderCell = rv
End Function
第10行的值是否始终为“ TOOL CUTTER”和“ HOLDER”? 这些列中是否总会有值? 您是否需要允许该列中的空白值以外的其他例外?
同时,这里有一些尝试:
Sub macro1()
Dim Sht As Worksheet
Dim LR As Integer, FR As Integer, ToolCol As Integer
Set Sht = ActiveSheet
With Sht 'Find column with TOOL CUTTER:
ToolCol = Application.WorksheetFunction.Match("TOOL CUTTER", .Range("10:10"), 0)
LR = .Cells(.Rows.Count, ToolCol).End(xlUp).Row 'Find last row with data in TOOL CUTTER column:
.Range(.Cells(11, ToolCol), .Cells(LR, ToolCol)).Copy
End With
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.