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
Related
I am trying to run the Find method between two ranges in two different workbooks - If a value in the second range isn't found in the first range, then the data in the entire row to which the aforesaid cell belongs to should be copied from the second workbook and pasted in the first workbook. Each time I try to run my code I get runtime error #438 - Object doesn't support this property or method:
Option Explicit
Sub Data_Transfer()
Dim FileToOpen As Variant
Dim FileCount As Byte, SheetCount As Byte, SheetFound As Byte
Dim SelectedBook As Workbook
Dim WkSh As Worksheet
Dim Cell As Range, ChosenCell As Range, LookInRange As Range, LookAtRange As Range
FileToOpen = Application.GetOpenFilename(Title:="Select Files to Import Data", FileFilter:="Excel Files(*.xls*), *.xls*", MultiSelect:=True)
If IsArray(FileToOpen) Then 'Allows the user to click on the 'Cancel' button without it leading to an error
For FileCount = 1 To UBound(FileToOpen)
Set SelectedBook = Workbooks.Open(FileToOpen(FileCount))
'If a worksheet already exists for the month:
For SheetCount = 1 To ThisWorkbook.Worksheets.Count
If ThisWorkbook.Worksheets(SheetCount).Name = VBA.Replace(SelectedBook.Name, ".xls", "") Then
SheetFound = 1
Set WkSh = ThisWorkbook.Worksheets(SheetCount)
WkSh.Activate
MsgBox "A worksheet already exists for the selected month."
'Check if there are any expenses missing for the month:
Set LookInRange = ThisWorkbook.ActiveSheet.Range("C2:C" & Range("C2").End(xlDown).Row)
Set LookAtRange = SelectedBook.ActiveSheet.Range("C23:C" & Range("C2").End(xlDown).Row)
For Each Cell In LookAtRange
Set ChosenCell = LookAtRange.Find(LookInRange.Cell, , xlValues, xlWhole)
If ChosenCell Is Nothing Then
ChosenCell.EntireRow.Copy WkSh.Range("A" & Range("A1").End(xlDown).Row + 1)
End If
Next Cell
End If
If SheetFound = 1 Then: Exit Sub
Next SheetCount
'If a worksheet does not exist for the month:
With ThisWorkbook
.Worksheets.Add After:=Sheet11
.ActiveSheet.Name = VBA.Replace(SelectedBook.Name, ".xls", "")
SelectedBook.Worksheets(1).Range("A23").CurrentRegion.Copy .ActiveSheet.Range("A1")
SelectedBook.Close
For Each Cell In .ActiveSheet.Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If VBA.Left(Cell.Value, 1) = "*" Then
Cell.EntireRow.Delete
End If
Next Cell
.ActiveSheet.Columns.AutoFit
End With
Next FileCount
End If
End Sub
Always specify for all Range, Cells, Rows and Columns objects in which workbook and worksheet they are.
If you don't do that for example like here:
Set LookAtRange = SelectedBook.ActiveSheet.Range("C23:C" & Range("C2").End(xlDown).Row)
Then the first Range is in SelectedBook.ActiveSheet but the second may be or may be not! As long it is not defined you don't know:
Set LookAtRange = SelectedBook.ActiveSheet.Range("C23:C" & SelectedBook.ActiveSheet.Range("C2").End(xlDown).Row)
So make clear that Range, Cells, Rows and Columns objects are always fully referenced to a workbook/worksheet.
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'm currently working on workbook where in column A:A of worksheet("STAM-Filialen") nearly all the names of the other worksheets are. I want only those worksheets named in column("A:A") in a single PDF. The code I use know makes it a separate file for each worksheet. Is it possible to use a sort of a same code to save it as a single PDF?
Dim myCell As Range
Dim lastCell As Long
Dim PathName As String
lastCell = lastRow("STAM-Filialen")
PathName = Range("I10").Value
Worksheets("STAM-Filialen").Activate
For Each myCell In ThisWorkbook.Worksheets("STAM-Filialen").Range("A2:A" & lastCell).Cells
Dim wksName As String
wksName = myCell.Text
ThisWorkbook.Worksheets(wksName).Range("A1:P60").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PathName & "DispoPlan.Filiaal " & wksName & ".PDF"
Next
I'd recommend moving all the values to a single sheet to print. Then delete this temporary sheet when done.
Here's an example of placing each range from each sheet side by side in a new sheet.
Option Explicit
Public Sub CreateSinglePDF()
Dim ws As Range: Set ws = ThisWorkbook.Sheets(1).Range("A1:A4")
Dim rangeDict As Object: Set rangeDict = CreateObject("Scripting.Dictionary")
Dim cell As Range
For Each cell In ws
If Not rangeDict.exists(cell.Value) And cell.Value <> "" Then
rangeDict.Add cell.Value, ThisWorkbook.Sheets(cell.Value).Range("A1:A5")
End If
Next
Dim printsheet As Worksheet
Set printsheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
Dim key As Variant
Dim i As Long: i = 1
For Each key In rangeDict
printsheet.Range(printsheet.Cells(1, i), printsheet.Cells(5, i)).Value = rangeDict(key).Value
i = i + 1
Next
printsheet.UsedRange.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\users\ryan\desktop\ExampleFile.pdf"
printsheet.Delete
End Sub
To convert multiple sheets into single pdf document,
first select multiple sheets
and use the Activesheet.ExportAsFixedFormat statement.
The print range of the page can be set in Page Setup.
Code
Sub test()
Dim WB As Workbook
Dim Ws As Worksheet
Dim sht As Worksheet
Dim PathName As String
Dim vWs() as String '<~~ Variable change
Dim rngDB As Range, rng As Range
Dim n As Integer
Set WB = ThisWorkbook
Set Ws = WB.Worksheets("STAM-Filialen")
PathName = Range("I10").Value
With Ws
Set rngDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
For Each rng In rngDB
n = n + 1
ReDim Preserve vWs(1 To n)
vWs(n) = rng.text '<~~ text
Set sht = Sheets(rng.Value)
With sht.PageSetup
.PrintArea = "a1:p60"
End With
Next rng
Sheets(vWs).Select '<~~ multiple sheets select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=PathName & "DispoPlan.Filiaal.PDF"
End Sub
Worksheets("STAM-Filialen")
Specipic Sheets selected
Single pdf
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
Daily I receive 3 Excel files via e-mail and I need file data on one workbook.
The layout of each file is different.
File names will have current date added.
File 1 name is : BlankApp_yyyymmdd.xls
File 2 name is : DisRep_yyyymmdd.xls
File 3 name is : PerApp_yyyymmdd.xls
From File 1, I need data from B2, A7, D11, G11 (Single row)
From File 2, I need data from A7, C8, E9, H9 (Single row), A11, C12, E13, H13 (single row), A15, C16, E17, H17 (single row) & A19, C20, E21, H21 (single row)
From File 3, I need data from B2, A7, D11, G11 (single row)
In summary I need six rows of data on my workbook, which should accumulate on a daily basis.
I found code which gives the outcome I require, but this only resolves part of the question i.e. File1 & File3. Still to find a answer for File2.
Sub BlankandPersonalised()
Const CellList As String = "B2,A7,D11,G11"
Const strFldrPath As String = "C:\New folder\" ' point to the folder where the files reside
Dim wsDest As Worksheet
Dim rngDest As Range
Dim rngCell As Range
Dim arrData() As Variant
Dim CurrentFile As String
Dim rIndex As Long, cIndex As Long
Set wsDest = ActiveWorkbook.ActiveSheet
CurrentFile = Dir(strFldrPath & "*.xls*")
Set rngDest = wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1)
ReDim arrData(1 To Rows.Count, 1 To Range(CellList).Cells.Count)
Application.ScreenUpdating = False
Do While Len(CurrentFile) > 0
With Workbooks.Open(strFldrPath & CurrentFile)
rIndex = rIndex + 1
cIndex = 0
For Each rngCell In .Sheets(1).Range(CellList).Cells
cIndex = cIndex + 1
arrData(rIndex, cIndex) = rngCell.Value
Next rngCell
.Close False
End With
CurrentFile = Dir
Loop
Application.ScreenUpdating = True
If rIndex > 0 Then rngDest.Resize(rIndex, UBound(arrData, 2)).Value = arrData
Set wsDest = Nothing
Set rngDest = Nothing
Set rngCell = Nothing
Erase arrData
End Sub
Option Explicit
Sub test()
Dim wb As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet2").Range("C3:D4").Value = wb.Worksheets("Sheet1").Range("A1:B2").Value
End Sub
Using above should be a good start. Not sure where you want the data or what book you want the macro in.
referenced from here
Copy data from another Workbook through VBA
Here is another example of how to pull all the files in one folder into a workbook.
if you just want to copy the entire sheet in one workbook you can use
Sub add_Sheets()
Dim was As Worksheet
Dim wb As Workbook
Set wb = Application.Workbooks.Open("C:\Location of your files") 'Location of where you want the workbook to be
StrFile = Dir("C:\Location\*.xls") 'Dir of where all the xls are.
Do While Len(StrFile) > 0
Debut.Print StrFile
Application.Workbooks.Open ("C:\Location\" & StrFile)
Set ws = ActiveSheet
ws.UsedRange.Select 'Used range of the worksheet
Selection.Copy
wb.Activate
wb.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = StrFile
Range("A1").PasteSpecial Paste:=xlPasteValues
StrFile = Dir
Loop
End Sub