I am copying files (cell list) from source to destination folder. I need to select all values from a column in excel in the form of ($A1).
My code:
Sub SourcetoDestination()
Dim rngFile As Range, cel As Range
Dim desPath As String, filename As String
Set rngFile = ThisWorkbook.Sheets("Sheet1").**Range("$A1")** 'assuming file list in ColA
desPath = "C:Destination\"
For Each cel In rngFile
If Dir(cel) <> "" Then
filename = Dir(cel)
FileCopy cel, desPath & filename 'copy to folder
End If
Next
End Sub
Problem:
My code only copy first value from the list.
if I specify range like this :
ThisWorkbook.Sheets("Sheet1").Range("A1","A3")
It works but I want to save absolute range in excel.
Could someone please guide me.Thanks in advance.
Is this what you need??:
Sub SourcetoDestination()
Dim rngFile As Range, cel As Range
Dim desPath As String, filename As String
Dim N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
Set rngFile = ThisWorkbook.Sheets("Sheet1").Range("$A1:$A" & N) 'assuming file list in ColA
desPath = "C:Destination\"
For Each cel In rngFile
If Dir(cel) <> "" Then filename = Dir(cel)
FileCopy cel, desPath & filename 'copy to folder
End If
Next
End Sub
UNTESTED
Related
provide path of files or folder in certain range of cells.
read those cells and copy those files/folder to a new folder.
create a zip of that folder.
Sample input:
Sub test()
Dim rngFile As Range, cel As Range
Dim desPath As String, filename As String
Set rngFile = ThisWorkbook.Sheets("Instructions").Range("A3", "A5")
desPath = "C:\test\"
For Each cel In rngFile
If Dir(cel) <> "" Then
filename = Dir(cel)
FileCopy cel, desPath & filename
End If
Next
End Sub
I am able to read and copy files but not able to copy folder. any way such it can copy files as well as folder which is mentioned in cells.
Try something like this:
Sub test()
Const DEST_PATH As String = "C:\test\" 'use const for fixed values
Dim rngFile As Range, cel As Range, p, fso As Object
Set fso = CreateObject("scripting.filesystemobject")
Set rngFile = ThisWorkbook.Sheets("Instructions").Range("A3:A5") ' : not ,
For Each cel In rngFile.Cells
cel.Font.Color = vbBlack
p = Trim(cel.Value)
If fso.FolderExists(p) Then 'is this a folder?
fso.copyfolder p, DEST_PATH
ElseIf fso.FileExists(p) Then 'is this a file?
fso.copyfile p, DEST_PATH
Else
cel.Font.Color = vbRed 'not an existing file or folder
End If
Next
End Sub
I have a task where I have two workbooks, one source and one destination. The task is to search a column in the destination workbook for a value that contains a certain string. When found, I have to search the source workbook in a certain column to find a matching string. I then take values from 2 other columns in that same row in the source workbook, combine them, and write them to a cell in the destination workbook.
The issue is that the values are being written to the wrong rows in the destination workbook, like this:
example1Broken
When it should look like this:
example2proper
Here is my current vba:
Sub CombineWorkbooks()
Dim var As Variant
Dim col As Variant
Dim i As Long
Dim Cell As Range
Dim wbSource As Workbook
Set wbSource = Workbooks.Open(Filename:="CopyFromWorkbookSource.xlsx", UpdateLinks:=3)
Dim wbDest As Workbook
Set wbDest = Workbooks.Open(Filename:="CopyFromWorkbookDest.xlsm", UpdateLinks:=3)
Dim address As Variant
Dim newAddressRow As Variant
Dim sourceVal1 As Variant
Dim sourceVal2 As Variant
'Dest wb number column that contains the search query
Dim sourceCol As Integer
sourceCol = 1
wbDest.Activate
'col = Split(ActiveCell(1).address(1, 0), "$")(0)
For i = 1 To Rows.Count
var = Cells(i, sourceCol).Value
If var Like "*WI*" And Not IsEmpty(Cells(i, sourceCol).Value) Then
wbSource.Activate
Set Cell = Nothing
Set Cell = Selection.Find(What:=var, LookIn:=xlValues)
If Cell Is Nothing Then
' MsgBox "Nothing"
Else
'We found a match!
MsgBox "Found hit for " & var & ": " & Cell.address
'This is where the value was found in the source workbook
address = Cell.address
'This is where the new value must go in the dest workbook NOTE the column letter must change!
newAddressRow = Split(address, "$A$")(1)
'Get the cell values from the source wb
sourceVal1 = Cells(newAddressRow, 2)
sourceVal2 = Cells(newAddressRow, 3)
MsgBox "SourceVal1: " & sourceVal1 & " SourceVal2: " & sourceVal2 & " Newaddressrow: " & newAddressRow & " i: " & i
'Activate the dest workbook for pasting
wbDest.Activate
'Write the source wb values into a single cell in the dest wb
Cells(i, 2).Value = sourceVal1 & Chr(10) & sourceVal2
End If
End If
Next i
End Sub
Consider removing the address variable and set the sourceVals using the found Cell's Row parameter. Also consider direct referencing workbooks and sheets instead of activating; see below.
Sub CombineWorkbooks()
Dim i As Long
Dim Cell As Range
Dim wbSource As Workbook
Dim wbDest As Workbook
Dim sourceCol As Integer 'Destwb number column that contains the search query
Set wbSource = Workbooks.Open(Filename:="CopyFromWorkbookSource.xlsx", UpdateLinks:=3)
Set wbDest = Workbooks.Open(Filename:="CopyFromWorkbookDest.xlsm", UpdateLinks:=3)
sourceCol = 1
' start at 2 to dodge the header
For i = 2 To wbDest.Sheets(1).Rows.Count
'this conditional can be removed if all non-header rows will contain WI
If wbDest.Sheets(1).Cells(i, sourceCol).Value Like "*WI*" Then
Set Cell = wbSource.Sheets(1).UsedRange.Find(What:=wbDest.Sheets(1).Cells(i, sourceCol).Value, LookIn:=xlValues)
If Not Cell Is Nothing Then
'We found a match!
'Write the source wb values into a single cell in the dest wb
Cells(i, 2).Value = wbSource.Sheets(1).Cells(Cell.Row, 2) & Chr(10) & wbSource.Sheets(1).Cells(Cell.Row, 3)
End If
End If
Next i
End Sub
I am working on a Macro to extract data from different rows (there are some blank rows) but I want it to search and extract instead of from a range to extract from columns A-D this can be from (A1:D100) then to stop the loop if A(x) where the content of X is "Results". Then to loop to the next workbook.
Sub tgr()
Dim wbDest As Workbook
Dim wsDest As Worksheet
Dim rCopy As Range
Dim sFolder As String
Dim sFile As String
Dim lRow As Long
Set wbDest = ThisWorkbook 'The workbook where information will be copied into
Set wsDest = wbDest.Worksheets("Sheet1") 'The worksheet where information will be copied into
sFolder = "C:\Path\" 'The folder path containing the xlsx files to copy from
'would like sFolder to be the root folder and also
' search for any "*.xlsx" contained inside C:\temp
lRow = 1 'The starting row where information will be copied into
'Adjust the folder path to ensure it ends with \
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
'Get the first .xlsx file in the folder path
sFile = Dir(sFolder & "*.xlsx")
'Begin loop through each file in the folder
Do While Len(sFile) > 0
'Open the current workbook in the folder
With Workbooks.Open(sFolder & sFile)
'Copy over the formulas from A1:C3 from only the first
' worksheet into the destination worksheet
Set rCopy = .Sheets(1).Range("C9:D26")
wsDest.Cells(lRow, "A").Resize(rCopy.Rows.Count, rCopy.Columns.Count).Formula = rCopy.Formula
'Advance the destination row by the number of rows being copied over
lRow = lRow + rCopy.Rows.Count
.Close False 'Close the workbook that was opened from the folder without saving changes
End With
sFile = Dir 'Advance to the next file
Loop
End Sub
Code 1 is used to find the FIRST occurrence of the string we search for:
Option Explicit
Sub test()
Dim rngSearch As Range, Position As Range
Dim strSearch As String
With ThisWorkbook.Worksheets("Sheet1")
Set rngSearch = .Range("A1:D100") '<- Set the range i want to search in
strSearch = "Test" '<- Set the string i want to search for
Set Position = rngSearch.Find(strSearch) '<- Search for string in range
If Not Position Is Nothing And .Range("A" & Position.Row).Value = "Results" Then '<- Check if string appears in the range and the value in column A and row where the string is "Results"
'Code here
End If
End With
End Sub
Code 2 is used to search the whole range and check ALL occurrence of string we search for:
Option Explicit
Sub test()
Dim rngSearch As Range, cell As Range
Dim strSearch As String
With ThisWorkbook.Worksheets("Sheet1")
Set rngSearch = .Range("A1:D100") '<- Set the range i want to search in
strSearch = "Test" '<- Set the string i want to search for
For Each cell In rngSearch
If cell.Value = strSearch And .Range("A" & cell.Row).Value = "Results" Then
'Code here
End If
Next cell
End With
End Sub
I am trying to come up with a routine that copies only certain files out of a directory, and all sub-directories, and pastes each copied file into a destination directory. I came up with the code below, which copies all files, in a filtered list, into a destination folder, but I can't figure out how to do a recursive loop through the hierarchy. Any guidance on this would be greatly appreciated.
Sub CopyFilteredFiles()
Dim rng As Range, cell As Range
Dim sht As Worksheet
Dim LastRow As Long
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim lastChar As Integer
Dim fileName As String
DestinationFolder = "C:\Users\ryans\OneDrive\Desktop\AllYAML\"
Set sht = ActiveSheet
LastRow = sht.Cells(sht.Rows.Count, "D").End(xlUp).Row
Set rng = Range("D14:D" & LastRow)
Set FSO = CreateObject("scripting.filesystemobject")
For Each cell In rng.SpecialCells(xlCellTypeVisible)
If cell.Value <> "" Then
CopyFile = cell.Value
Debug.Print cell.Value
lastChar = InStrRev(CopyFile, "\")
fileName = Mid(CopyFile, lastChar + 1, 199)
On Error Resume Next
FSO.CopyFile Source:=CopyFile, Destination:=DestinationFolder & fileName
End If
Next cell
End Sub
I have two questions but first a bit of background...
I have a number of workbooks each containing a different number of worksheets all saved in the same folder. Each worksheet except the first has an invoice from which I need data from specific cells copied on to the master sheet.
The Master sheet has 5 columns which will be populated with the information from the same 5 cells on each sheet on the following row.
Invoice Sheets Cell Master Sheet Row
E9 A
D18 B
D22 C
E11 D
F27 E
.
Sub Consolidate()
Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim ColDest As String
Dim ColSrc As String
Dim RngDest As String
Dim RngSrc As String
Dim InvTotal As String
Dim RowInstructCrnt As Long
Dim RowSrcEnd As Long
Dim RowSrcStart As Long
Set destsheet = Workbooks("Test Master.xlsm").Worksheets("Sheet1")
'get list of all files in folder
Fname = Dir(ThisWorkbook.Path & "/*.xlsx")
'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets("Sheet1")
'find first empty row in destination table
ResultRow = destsheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
'start at top of list of cell references and work down until empty cell reached
Application.Goto ThisWorkbook.Worksheets("Sheet1").Range("D16")
With ThisWorkbook.Worksheets("Sheet1")
Do While Not IsEmpty(.Cells(16, 4))
ColSrc = .Cells(9, 5)
RowSrcStart = .Cells(18, 4)
RowSrcEnd = .Cells(22, 4)
ColDest = .Cells(11, 5)
InvTotal = .Cells(27, 6)
RngSrc = ColSrc & RowSrcStart & ColSrc & RowSrcEnd & InvTotal
RngDest = ColDest & ResultRow
originsheet.Range(RngSrc).Copy
destsheet.Range(RngDest).PasteSpecial
Loop
End With
Workbooks(Fname).Close SaveChanges:=False 'close current file
Fname = Dir 'get next file
Loop
End Sub
So my first question is - how can I modify this code to make it paste the correct information in the correct cells...
Secondly - I've not yet attempted looping through each sheet in the workbooks as I'm not sure where to begin...
Any advice would be greatly appreciated
Untested:
Sub Consolidate()
Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim RngDest As Range
Set destsheet = ThisWorkbook.Worksheets("Sheet1")
Set RngDest = destsheet.Cells(Rows.Count, 1).End(xlUp) _
.Offset(1, 0).EntireRow
Fname = Dir(ThisWorkbook.Path & "/*.xlsx")
'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
If Fname <> ThisWorkbook.Name Then
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets("Sheet1")
With RngDest
.Cells(1).Value = originsheet.Range("E9").Value
.Cells(2).Value = originsheet.Range("D18").Value
.Cells(3).Value = originsheet.Range("D22").Value
.Cells(4).Value = originsheet.Range("E11").Value
.Cells(5).Value = originsheet.Range("F27").Value
End With
wkbkorigin.Close SaveChanges:=False 'close current file
Set RngDest = RngDest.Offset(1, 0)
End If
Fname = Dir() 'get next file
Loop
End Sub