How can I copy the columns (data only) with these column header names "TOOL CUTTER" and "HOLDER" and paste them (as an append in just one column each with the same column header name) into another workbook sheet where the VBA code (Sheet Module) is. Thanks. The column header HOLDER occurs in F10 (preferably written as (10, 6), and TOOL CUTTER is in G10 (10, 11) but it would be preferred to have it search for the header name and print whatever is in that column until it is completely empty (blank spaces may occur). Any help is greatly appreciated!!
Working code: opens files in folder in a loop – opens file, prints name of file to Masterfile sheet, prints item J1 from file to Masterfile sheet, closes file, opens next file in the folder until all have been looped through.
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
Code I’m working on to try to print the values in the HOLDER and TOOL CUTTER columns (returns error Tool variable is not defined in line For Each Tool In TOOLList
in the block that starts with the comment 'paste the TOOL list found back to this sheet :
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
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
– TaylorTool
. That is why you're getting the error it's not defined. – thunderblasterDim Tool As Object
, the lineFor Each ws In .Worksheets
returns an automation error – TaylorDim Tool As Variant
. More info on variants: msdn.microsoft.com/en-us/library/office/gg251448.aspx – thunderblaster