I have a code that successfully merges data from a specific named sheets of multiple workbooks into specific master workbook sheet.
However, the code merges empty rows too that have some sort of formatting in them. In my case, the source sheets have boderlines without any values in the empty rows. I tried using SourceRange.Range(FirstCell & ":" & RDB_Last(3, .Cells)).ClearFormats but it fails to resolve the problem.
If I manually clear the formatting from the source files, save the file and then run the code it works right. But that's not possible in real time scenario.
A novice to VBA. Please help. Thanks in Advance.
My Files are shared in G Drive: Sample Data
Note: RDM_Last is a Function used to determine the last row/cell with value. I have added the code below the main code.
The Code:
Sub MergeAllWorkbooks2()
Dim FirstCell As String
Dim MyPath As String, FilesInPath As String
Dim myFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
' Change this to the path\folder location of your files.
MyPath = "C:\Users\zatin.dharmapuri\Desktop\3. 2018\Raw Data Month wise\Jan-2018"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve myFiles(1 To FNum)
myFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' The sheet name for the data to be copied to.
Set BaseWks = ThisWorkbook.Sheets("Sheet3")
rnum = 2
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(myFiles) To UBound(myFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & myFiles(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
'Change this range to fit your own needs.
'With mybook.Worksheets("Defect Analysis Reports")
'Set sourceRange = .Range("A5:J104")
'End With
With mybook.Worksheets("Defect Analysis Reports")
FirstCell = "A5"
Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
.Range(FirstCell & ":" & RDB_Last(3, .Cells)).ClearFormats
'Test if the row of the last cell >= then the row of the FirstCell
If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
Set sourceRange = Nothing
End If
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
' Copy the file name in column A.
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = myFiles(FNum)
End With
' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)
' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next FNum
'BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
MsgBox "All Data has been merged successfully"
End Sub
EDIT
RDM_Last Function Code:
Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
RDB_Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function
Use .Range(FirstCell & ":" & RDB_Last(3, .Cells)).ClearFormats instead of Range(FirstCell & ":" & RDB_Last(3, .Cells)).ClearFormats.
If you want to refer to range within certain sheet while using With you should refer to ranges using dot before range i.e. .Range. Currently your range may refer to some other sheet.
Ok,
This got resolved and it was a silly miss. It's not formatting that is the issue. Several of the files have latent data in cells BI520:CU531. That's messed up the LastCell calculation.
Credit goes to AlfaFrog from
https://www.excelforum.com/members/235459.html
Thanks for the time experts.
Related
I'm new to VBA, and I'd like to use it to do some difficult and arduous tasks. I have a large amount of Excel files with thousands of rows and several columns. I need to search, by row, and extract certain cells with specific strings. I've pieced together some functions and code and I have almost got it to work but I keep getting unexpected results like irrelevant data being extracted or it random errors because I don't understand VBA syntax super well. As a newbie to Excel, I'm at my wits end debugging this code and it still not giving me the results I need. My code thus far is as follows:
Option Explicit
Sub ImportDataFromMultipleFiles()
Dim firstAddress As Variant
Dim filenames As Variant
Dim i As Long
Dim rFind As Range
Dim firstFile As String
Dim n As Long
Dim r As Range
Dim myArray() As Integer
ThisWorkbook.Activate
Application.ScreenUpdating = False
Range("a2").Select
filenames = Application.GetOpenFilename _
(FileFilter:="Excel Filter(*xlsx), *.xlsx", MultiSelect:=True)
Application.FindFormat.Clear
For i = 1 To UBound(filenames) 'counter for files
firstFile = filenames(i)
Workbooks.Open firstFile 'Opens individual files in folder
n = 0
With ActiveSheet.UsedRange
Set rFind = .Find("Test*Results:", Lookat:=xlPart, MatchCase:=True, SearchFormat:=False)
If Not rFind Is Nothing Then
firstAddress = rFind.Address
Do
n = n + 1
Set rFind = .FindNext(rFind)
Selection.Copy
ThisWorkbook.Activate
Selection.PasteSpecial
ActiveCell.Offset(0, 1).Activate
Loop While Not rFind Is Nothing And rFind.Address <> firstAddress
End If
End With
ReDim myArray(0, n)
n = 0
Workbooks.Open firstFile 'Opens individual files in folder
With ActiveSheet.UsedRange
Set rFind = .Find("Test*Results:", Lookat:=xlPart, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
firstAddress = rFind.Address
Do
myArray(0, n) = rFind.Row '<<< Error currently here
n = n + 1
Set rFind = .FindNext(rFind)
Selection.Copy
ThisWorkbook.Activate
Selection.PasteSpecial
ActiveCell.Offset(0, 1).Activate
Loop While Not rFind Is Nothing And rFind.Address <> firstAddress
End If
End With
For n = LBound(myArray) To UBound(myArray)
Debug.Print "Rows are: " & myArray(0, n)
Next n
Workbooks.Open filenames(i)
ActiveWorkbook.Close SaveChanges:=False
ActiveCell.Offset(1, 0).Activate
Next i
End Sub
I'm not even sure if the second loop is necessary, but using it has given me the closest results for what I'm looking for thus far. This code is going to cover a lot of data, so any suggestions to make my code more efficient as well will be much appreciated.
Thanks in advance!
You definitely don't need all that code.
Try this out - it's easier to manage if you split out the "find" part into a separate method.
Option Explicit
Sub ImportDataFromMultipleFiles()
Dim filenames As Variant, wb As Workbook
Dim rngDest As Range, colFound As Collection, f, i As Long
Set rngDest = ActiveSheet.Range("A2") '<< results start here
filenames = Application.GetOpenFilename( _
FileFilter:="Excel Filter(*xlsx), *.xlsx", MultiSelect:=True)
If TypeName(filenames) = "Boolean" Then Exit Sub '<< nothing selected
Application.FindFormat.Clear
For i = 1 To UBound(filenames) 'counter for files
Set wb = Workbooks.Open(filenames(i))
Set colFound = FindAll(wb.Sheets(1).UsedRange, "Test*Results:") '<< get matches
Debug.Print "Found " & colFound.Count & " matches in " & wb.Name '<<EDIT
For Each f In colFound
f.Copy rngDest
Set rngDest = rngDest.Offset(1, 0)
Debug.Print "", f.Value
Next f
wb.Close False
Next i
End Sub
Public Function FindAll(rng As Range, val As String) As Collection
Dim rv As New Collection, f As Range
Dim addr As String
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.Count), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function
I am trying to merge data from particular columns from multiple csv files. This thread: Excel VBA - Merge specific columns from multiple files to one sheet worked for whole ranges of columns. However, I want to copy e.g. each 100th cell from particular column (instead of whole column as it is at the moment).
I have tried to modify the code as per below method 1 and 2 (see **** notes).
This VBA is to go through datalog files which have time stamps in rows and parameters for each time stamp. However, I don't want all parameters, only selected ones (per columns) and in each 100th row.
'takes worksheet and returns last row
Private Function LastRowUsed(sh As Worksheet) As Long
On Error Resume Next
LastRowUsed = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'takes worksheet and returns last column
Private Function LastColUsed(sh As Worksheet) As Long
On Error Resume Next
LastColUsed = sh.Cells.Find(What:="*", _
After:=sh.Range(A1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
'takes worksheet and returns last row in column
Private Function LastRowUsedbyCol(sh As Worksheet, ByVal Col As String) As Long
On Error Resume Next
LastRowUsed = sh.Cells.Find(What:="*", _
After:=sh.Range(Cell(Col, 1), Cell(Col, 1)), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function GetFileListArray() As String()
Dim fileDialogBox As FileDialog
Dim SelectedFolder As Variant
Dim MYPATH As String
Dim MYFILES() As String
Dim FILESINPATH
Dim FNUM, i As Integer
'''''
Set fileDialogBox = Application.FileDialog(msoFileDialogFolderPicker)
'Use a With...End With block to reference the FileDialog object.
With fileDialogBox
If .Show = -1 Then 'the user chose a folder
For Each SelectedFolder In .SelectedItems
MYPATH = SelectedFolder 'asign mypath to the selected folder name
'MsgBox "The path is:" & SelectedFolder, vbInformation 'display folder selected
Next SelectedFolder
'The user pressed Cancel.
Else
MsgBox "Cancel was pressed or Invalid folder chosen, ending macro"
Exit Function
End If
End With
'Set the file dialog object variable to Nothing to clear memory
Set fileDialogBox = Nothing
If Right(MYPATH, 1) <> "\" Then
MYPATH = MYPATH & "\"
End If
FILESINPATH = Dir(MYPATH & "*.csv")
'MsgBox FILESINPATH
If FILESINPATH = "" Then
MsgBox "No files found"
Exit Function
End If
'Fill the array(myFiles)with the list of Excel files in the folder
FNUM = 0
Do While FILESINPATH <> ""
FNUM = FNUM + 1
ReDim Preserve MYFILES(1 To FNUM)
MYFILES(FNUM) = MYPATH & FILESINPATH
FILESINPATH = Dir()
Loop
GetFileListArray = MYFILES()
End Function
Sub RFSSearchThenCombine()
'search first worksheet in files opened, change to search other worksheets
Const SHEET_TO_SEARCH = 1
Dim FileList() As String
Dim CurrentFolder As String
Dim openedWorkBook As Workbook, HeadingWorkbook As Workbook
Dim OpenedWorkSheet As Worksheet, HeadingWorkSheet As Worksheet
Dim i, counter, x, j As Integer
Dim LRowHeading, LRowOpenedBook, LColHeading, LColOpenedBook, LRowHeadingC As Long
Dim dict As dictionary
Dim searchValue
'set original workbook with headings to retrieve
Set HeadingWorkbook = ActiveWorkbook
Set HeadingWorkSheet = HeadingWorkbook.Sheets(1)
'find last column on heading worksheet
LColHeading = LastColUsed(HeadingWorkSheet)
'create dictionary to link headers to position in heading worksheet
Set dict = CreateObject("Scripting.Dictionary")
For x = 1 To LColHeading
dict.Add HeadingWorkSheet.Cells(1, x).Value, x
Next x
FileList() = GetFileListArray()
For counter = 1 To UBound(FileList)
Set openedWorkBook = Workbooks.Open(FileList(counter))
Set OpenedWorkSheet = openedWorkBook.Sheets(SHEET_TO_SEARCH)
LColOpenedBook = LastColUsed(openedWorkBook.Sheets(1))
LRowOpenedBook = LastRowUsed(openedWorkBook.Sheets(1))
LRowHeading = LastRowUsed(HeadingWorkSheet)
For i = 1 To LColOpenedBook 'search headers from a1 to last header
searchValue = OpenedWorkSheet.Cells(1, i).Value 'set search value in to current header
If dict.Exists(searchValue) Then
' *** code from previous thread
'OpenedWorkSheet.Range(OpenedWorkSheet.Cells(1, i), _
'OpenedWorkSheet.Cells(LRowOpenedBook, i)).Copy _
'(HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)))
'**** my proposal
For j = 1 To LRowOpenedBook Step 100
OpenedWorkSheet.Range(OpenedWorkSheet.Cells(j, i), _
OpenedWorkSheet.Cells(j, i)).Copy _
(HeadingWorkSheet.Cells(LRowHeading + 1, dict.Item(searchValue)))
LRowHeading = LRowHeading + 1
'**** my 2nd proposal
'LRowHeadingC = HeadingWorkSheet.Cells(Rows.Count, i).End(xlUp).Row
'For j = 1 To LRowOpenedBook Step 100
' OpenedWorkSheet.Range(OpenedWorkSheet.Cells(j, i), _
'OpenedWorkSheet.Cells(j, i)).Copy _
'(HeadingWorkSheet.Cells(LRowHeadingC + 1, dict.Item(searchValue)))
'LRowHeadingC = LRowHeadingC + 1
Next j
End If
Next i
openedWorkBook.Close (False)
Next counter ' move on to next file
End Sub
1st method (when working) results in shift of rows from next columns (all pasted data start from last row (not last row in particular column), it more less results in below pattern (where cl is for column and x represents data):
cl1 cl2 cl3 cl3
x
x
x
x
x
x
x
x
x x
x
x
x
x
x
While I want to receive below pattern:
cl1 cl2 cl3 cl3
x x x x
x x x x
x x x x
Another question is how should I modify function: LastRowUsed not to start from A1, but e.g. from B1, etc.? I tried to resolve that with Method 2.
Based on feedback above I have changed the loops order and that made it work. I have also polished the code (copying from range to range and added option explicit). Code does the job now.
Now I will be trying to change it to more efficient version (it takes plenty of time with few hundreds of workbooks). At the moment I am copying and pasting each cell individually between workbooks. I think that a set of cells (e.g. multiple selection of each 100th cell) would be quicker.
Or building an array of values needed and pasting array into headingsWorkbook as range.
Here is how the code looks now:
Option Explicit
'takes worksheet and returns last row
Private Function LastRowUsed(sh As Worksheet) As Long
On Error Resume Next
LastRowUsed = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'takes worksheet and returns last column
Private Function LastColUsed(sh As Worksheet) As Long
On Error Resume Next
LastColUsed = sh.Cells.Find(What:="*", _
After:=sh.Range(A1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
'takes worksheet and returns last row in column
Private Function LastRowUsedbyCol(sh As Worksheet, ByVal Col As String) As Long
On Error Resume Next
LastRowUsed = sh.Cells.Find(What:="*", _
After:=sh.Range(Cell(Col, 1), Cell(Col, 1)), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function GetFileListArray() As String()
Dim fileDialogBox As FileDialog
Dim SelectedFolder As Variant
Dim MYPATH As String
Dim MYFILES() As String
Dim FILESINPATH
Dim FNUM, i As Integer
'''''
Set fileDialogBox = Application.FileDialog(msoFileDialogFolderPicker)
'Use a With...End With block to reference the FileDialog object.
With fileDialogBox
If .Show = -1 Then 'the user chose a folder
For Each SelectedFolder In .SelectedItems
MYPATH = SelectedFolder 'asign mypath to the selected folder name
'MsgBox "The path is:" & SelectedFolder, vbInformation 'display folder selected
Next SelectedFolder
'The user pressed Cancel.
Else
MsgBox "Cancel was pressed or Invalid folder chosen, ending macro"
Exit Function
End If
End With
'Set the file dialog object variable to Nothing to clear memory
Set fileDialogBox = Nothing
If Right(MYPATH, 1) <> "\" Then
MYPATH = MYPATH & "\"
End If
FILESINPATH = Dir(MYPATH & "*.csv")
'MsgBox FILESINPATH
If FILESINPATH = "" Then
MsgBox "No files found"
Exit Function
End If
'Fill the array(myFiles)with the list of Excel files in the folder
FNUM = 0
Do While FILESINPATH <> ""
FNUM = FNUM + 1
ReDim Preserve MYFILES(1 To FNUM)
MYFILES(FNUM) = MYPATH & FILESINPATH
FILESINPATH = Dir()
Loop
GetFileListArray = MYFILES()
End Function
Sub RFSSearchThenCombineEach1000thRow()
'search first worksheet in files opened, change to search other worksheets
Const SHEET_TO_SEARCH = 1
Dim FileList() As String
Dim CurrentFolder As String
Dim openedWorkBook As Workbook, HeadingWorkbook As Workbook
Dim OpenedWorkSheet As Worksheet, HeadingWorkSheet As Worksheet
Dim i, counter, x, j As Integer
Dim LRowHeading, LRowOpenedBook, LColHeading, LColOpenedBook As Long
Dim dict As dictionary
Dim searchValue
'set original workbook with headings to retrieve
Set HeadingWorkbook = ActiveWorkbook
Set HeadingWorkSheet = HeadingWorkbook.Sheets(1)
'find last column on heading worksheet
LColHeading = LastColUsed(HeadingWorkSheet)
'create dictionary to link headers to position in heading worksheet
Set dict = CreateObject("Scripting.Dictionary")
For x = 1 To LColHeading
dict.Add HeadingWorkSheet.Cells(1, x).Value, x
Next x
FileList() = GetFileListArray()
For counter = 1 To UBound(FileList)
Set openedWorkBook = Workbooks.Open(FileList(counter))
Set OpenedWorkSheet = openedWorkBook.Sheets(SHEET_TO_SEARCH)
LColOpenedBook = LastColUsed(openedWorkBook.Sheets(1))
LRowOpenedBook = LastRowUsed(openedWorkBook.Sheets(1))
LRowHeading = LastRowUsed(HeadingWorkSheet)
For j = 2 To LRowOpenedBook Step 1000
LRowHeading = LRowHeading + 1 'move one row down in HeadingWorkbook, each 1000 rows of openedworkbook
For i = 1 To LColOpenedBook 'search headers from a1 to last header
searchValue = OpenedWorkSheet.Cells(1, i).Value 'set search value in to current header
If dict.Exists(searchValue) Then
OpenedWorkSheet.Range(OpenedWorkSheet.Cells(j, i), _
OpenedWorkSheet.Cells(j, i)).Copy _
HeadingWorkSheet.Range(HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)), _
HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)))
End If
Next i
Next j
openedWorkBook.Close (False)
Next ' move on to next file
End Sub
I’m relatively new in VBA, and currently I’m working on a macro in Master_file.xlsm, which contains multiple ranges of data that have to fill several .xlsb files in a folder.
Sheet Control contains in A2 the Folder path, which contains all the .xlsb files to be filled, and column D the file names.
Sheet Churn contains at column A the same file names, followed by its respective range to be paste at the .xlsb file.
This is all I have so far.
Sub Fill_NNAs()
Dim FilePath As String
Dim iCell As String
Dim BC As String
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveWorkbook.Sheets("Control").Activate
LastRow = Range("D2").End(xlDown).Row
intRowCount = LastRow
FilePath = ActiveSheet.Range("A2").Value
For i = 2 To intRowCount
iCell = Cells(i, 4).Value
BC = Cells(i, 3).Value
Worksheets("Churn").Activate
Columns("A:A").Select
x = Selection.Find(What:=BC, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range(ActiveCell.Offset(1, 1), ActiveCell.Offset(3, 64)).Select
Selection.Copy
Workbooks.Open FileName:=FilePath & iCell, ReadOnly:=False, UpdateLinks:=0
ActiveWorkbook.UpdateLinks = xlUpdateLinksNever
Sheets("Summary_ARD").Select
Range("C89:BN91").Select
ActiveSheet.Paste
ActiveWindow.Close SaveChanges:=True
Workbooks("Master_file.xlsm").Activate
Sheets("Control").Select
Next
MsgBox "Completed successfully!"
End Sub
As you can see, my loop goes to sheet Control, get the first file name, searches for it on Churn, copies its respective range, open Filename.xlsb, activated Summary_ARD sheet, paste it and goes to the next.
It has been working fine, but now I have a new problem:
Some xlsb files have more than one “Summary_ARD” sheet, like Summary_ARD, Summary_ARD (2), Summary_ARD (3), and some have New_ARD sheet instead of Summary_ARD.
So, what my code has to do now when open a new Filename.xlsb is:
Activate the Summary_ARD with the highest number in parenthesis (Summary_ARD (5) instead of (4), etc).
If there is no sheet Summary_ARD (number), activate Summary_ARD.
If there is no sheet Summary_ARD, activate New_ARD.
For all itens above, it has to look only in the visible sheets.
Any ideas?
If whatever your target sheet is is the last sheet in the WB, you can just reference it by its .index number - the last one being sheets.count -
Oh, I restructured your code so you're not using .selection or .activate
Sub Fill_NNAs()
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
Dim wbDest As Workbook
Dim FilePath As String
FilePath = ActiveSheet.Range("A2").Value
Dim iCell As String
Dim BC As String
Dim rngSearch As Range
Dim lastrow As Integer
lastrow = Range("D2").End(xlDown).Row
Dim wsControl As Worksheet
wsControl = ThisWorkbook.Sheets("Control")
Dim wsChurn As Worksheet
wsChurn -ThisWorkbook.Sheets("Churn")
For i = 2 To lastrow
iCell = wsControl.Cells(i, 4).Value
BC = wsControl.Cells(i, 3).Value
Set rngSearch = wsChurn.Columns(1).Find(What:=BC, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Set rngSearch = Range(rngSearch.Offset(1, 1), rngSearch.Offset(3, 64))
Workbooks.Open Filename:=FilePath & iCell, ReadOnly:=False, UpdateLinks:=0
ActiveWorkbook.UpdateLinks = xlUpdateLinksNever
ActiveWorkbook.Sheets(Sheets.Count).Range("C89:BN91") = rngSearch
ActiveWindow.Close SaveChanges:=True
Next
MsgBox "Completed successfully!"
End Sub
Otherwise, you might need to get a little tricky with something like this -
Sub testb()
Dim j As Integer
j = 0
Dim wsDest As Worksheet
For Each ws In ThisWorkbook.Sheets
If InStr(1, ws.Name, "(") Then
If Mid(ws.Name, InStr(1, ws.Name, "(") + 1, 1) > j Then
j = Mid(ws.Name, InStr(1, ws.Name, "(") + 1, 1)
End If
End If
Next
If j = 0 Then
If SheetExists("Summary_ARD") Then
wsDest = ThisWorkbook.Sheets("Summary_ARD")
Else: wsDest = ThisWorkbook.Sheets("New_ARD")
GoTo label
End If
End If
Set wsDest = ActiveWorkbook.Sheets("Summary_ARD(" & j & ")")
label:
'do stuff with wsdest
End Sub
Function SheetExists(strWSName As String) As Boolean
Dim ShTest As Worksheet
On Error Resume Next
Set ShTest = Worksheets(strWSName)
If Not ShTest Is Nothing Then SheetExists = True
End Function
For your loop to find the sheet, this might work
Sub findsheet()
Dim i As Integer
Dim shTest As Worksheet
For i = 1 To 20
On Error GoTo label
Set shTest = Worksheets("Summary_ARD(" & i & ")")
Next
label:
If i > 1 Then
Set shTest = Worksheets("Summary_ARD(" & i - 1 & ")")
GoTo label3
End
On Error GoTo label2
Set shTest = Worksheets("Summary_ARD")
GoTo label3
label2:
Set shTest = Worksheets("New_ARD")
GoTo label3
label3:
'do stuff
End Sub
I don't know if i'm being dumb (probably), but I just put your loop in the place of mine old Sheets("Summary_ARD").Select, and it doesn't work. I got stuck in the "label" line.
Sub Fill_NNAs()
Dim FilePath As String
Dim iCell As String
Dim BC As String
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveWorkbook.Sheets("Control").Activate
LastRow = Range("D2").End(xlDown).Row
intRowCount = LastRow
FilePath = ActiveSheet.Range("A2").Value
For i = 2 To intRowCount
iCell = Cells(i, 4).Value
BC = Cells(i, 3).Value
Worksheets("Churn").Activate
Columns("A:A").Select
x = Selection.Find(What:=BC, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range(ActiveCell.Offset(1, 1), ActiveCell.Offset(3, 64)).Select
Selection.Copy Workbooks.Open FileName:=FilePath & iCell, ReadOnly:=False, UpdateLinks:=0 ActiveWorkbook.UpdateLinks = xlUpdateLinksNever
On Error GoTo label
Set shTest = Worksheets("Summary_ARD(" & i & ")")
Next
label:
If i > 2 Then
Set shTest = Worksheets("Summary_ARD(" & i - 1 & ")")
GoTo label3
End
On Error GoTo label2
Set shTest = Worksheets("Summary_ARD")
GoTo label3
label2:
Set shTest = Worksheets("New_ARD")
GoTo label3
label3:
Range("C89:BN91").Select
ActiveSheet.Paste
ActiveWindow.Close SaveChanges:=True
Workbooks("Master_file.xlsm").Activate
Sheets("Control").Select
Next
MsgBox "Completed successfully!"
End Sub
Oh sorry, I don't use your re-writed code.
I'm doing this code for the company where I work as a internship. I did some part of it with the help of people from this forum and others but the code is big and I cannot find a place or the piece of code needed to do what I asked for, and that fits my code I'm newbie by the way.
So I will explain the code IT will import from a target excel file and then paste in my main file, after that it will search in the main file for the data that is present in the column A and then copy the information that is linked to the names and paste it in the import sheet called (Status) so I wanted to put a delete duplications before searching the information in the main file.
Sorry for the Big code. Forgot to mentioned the files come duplicated from the source file but I cannot change the source file, probably is easier if the import doesn't take duplicated rows ?
Sub ImportData()
Application.ScreenUpdating = False
Dim Path As String, Lstrw As Long
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Path = "C:\Users\DZPH8SH\Desktop\Status 496 800 semana 12 2015.xls" 'Change this to your company workbook path
workbook path
Set SourceWb = Workbooks.Open(Path)
Set TargetWb = ThisWorkbook
Dim n As Integer, targetRow As Long
targetRow = 3
With SourceWb.Sheets(1)
Lstrw = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
.Range("M1:M" & Lstrw).AutoFilter Field:=1, Criteria1:="496"
.Application.Union(.Range("D2:D" & Lstrw), .Range("F2:F" & Lstrw), .Range("I2:I" & Lstrw), .Range("M2:M" & Lstrw)).Copy
TargetWb.Sheets(7).Cells(TargetWb.Sheets(7).Rows.Count, "A").End(xlUp)(2).PasteSpecial xlPasteValues
.ShowAllData
End With
With SourceWb.Sheets(2)
Lstrw = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
.Application.Union(.Range("D2:D" & Lstrw), .Range("F2:F" & Lstrw), .Range("I2:I" & Lstrw), .Range("M2:M" & Lstrw)).Copy
TargetWb.Sheets(7).Cells(TargetWb.Sheets(7).Rows.Count, "A").End(xlUp)(2).PasteSpecial xlPasteValues
End With
SourceWb.Close savechanges:=False
Application.ScreenUpdating = True
'====================================== Search in the main file code below
On Error Resume Next
Dim CurrWk As Worksheet
Dim wb As Workbook
Dim wk As Worksheet
Dim LRow As Integer
Dim myLRow As Integer
Dim myLCol As Integer
Dim F1 As Boolean
Dim f As Boolean
Set wb = ActiveWorkbook
Set CurrWk = wb.Sheets(7)
LRow = LastRow(CurrWk)
For r = 3 To LRow
f = False
For Each wk In wb.Worksheets
If wk.Name = "Status" Or wk.Name = "Gráfico_2015" Then GoTo abc 'Exit For
If wk.Visible = xlSheetHidden Then GoTo abc 'Exit For
myLRow = LastRow(wk)
myLCol = LastCol(wk)
For r1 = 3 To myLRow
For c1 = 1 To myLCol
If Trim(CurrWk.Cells(r, 1).Value) = Trim(wk.Cells(r1, c1).Value) Then
f = True
F1 = False
If wk.Name = "ÄA" Then
For I = 12 To 18
If wk.Cells(r1, I).Value = 1 Then
CurrWk.Cells(r, 6).Value = wk.Cells(2, I).Value
F1 = True
Exit For
End If
Next I
Else
For I = 14 To 20
If wk.Cells(r1, I).Value = 1 Then
CurrWk.Cells(r, 6).Value = wk.Cells(2, I).Value
F1 = True
Exit For
End If
Next I
End If
If F1 = False Then CurrWk.Cells(r, 6).Value = "Set de equipa diferente"
End If
Next c1
Next r1
'If f = True Then Exit For
abc:
Next wk
If f = False Then
CurrWk.Cells(r, 12).Value = "Não está presente no ficheiro"
End If
Next r
Set wk = Nothing
Set wb = Nothing
On Error GoTo 0
MsgBox "Finished"
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
You could try exploring this avenue...
https://msdn.microsoft.com/en-us/library/office/ff193823.aspx
Using the VBA side of Range.RemoveDuplicates instead of manually just doing Remove Duplicates from the Data ribbon.
I have one button macro for reading data from excel files after leaving some(irrelevent starting rows of detail) rows(A1-A10) and merging all those files in single file.
It runs correctly when i use product files(excel files which have details about particular product). But when i use excel files which has company details it reads one row from irrelevant row(A5) then goes to the relevant data part to read.
I am not able to understand why it is reading one row i.e. company name from company excel files. i want it to directly go to (A11)th row to read. Which it does with produt files.
Product files are the files which have particular product details.
Whereas Company Files are the files which has details of all products of particular company.
With my code below, i want to know that why it is reading company name(row A5), which it should not read.
Sub Button2_Click()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim SourceRcount As Long
Dim N As Long
Dim rnum As Long
Dim MyPath As String
Dim SaveDriveDir As String
Dim FName As Variant
SaveDriveDir = CurDir
MyPath = "C:\"
ChDrive MyPath
ChDir MyPath
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls", _
MultiSelect:=True)
If IsArray(FName) Then
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
For N = LBound(FName) To UBound(FName)
Set mybook = Workbooks.Open(FName(N))
rnum = LastRow(basebook.Worksheets(1)) + 1
Set sourceRange = mybook.Worksheets(1).UsedRange
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum, "A")
'basebook.Worksheets(1).Cells(rnum, "D").Value = mybook.Name
' This will add the workbook name in column D if you want
sourceRange.Copy destrange
' Instead of this line you can use the code below to copy only the values
' With sourceRange
' Set destrange = basebook.Worksheets(1).Cells(rnum, "A"). _
' Resize(.Rows.Count, .Columns.Count)
' End With
' destrange.Value = sourceRange.Value
mybook.Close False
'Clear Rows
rnum = LastRow(basebook.Worksheets(1)) + 1
While Not rnum = 2
If basebook.Worksheets(1).Cells(rnum, 1).Value = "" Or
Left(basebook.Worksheets(1).Cells
(rnum, 1).Value, 9) = "Copyright" Or Left
(basebook.Worksheets(1).Cells(rnum, 1).Value, 4) = "Free" Or Left
(basebook.Worksheets(1).Cells(rnum, 1).Value, 7) = "Product" Or
Left(basebook.Worksheets(1).Cells(rnum, 1).Value, 9) = "Intl Port" Or
Left(basebook.Worksheets(1).Cells(rnum, 1).Value, 5) = "House" Or
Left(basebook.Worksheets(1).Cells(rnum, 1).Value, 7) = "Arrival" Or
Left(basebook.Worksheets(1).Cells(rnum, 1).Value, 5) = "Bill " Then
basebook.Worksheets(1).Rows(rnum).Delete
End If
rnum = rnum - 1
Wend
Next
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Instead of this:
Set sourceRange = mybook.Worksheets(1).UsedRange
SourceRcount = sourceRange.Rows.Count
Try this:
With mybook.Worksheets(1)
SourceRcount = .UsedRange.Rows.Count
Set sourceRange = .UsedRange.Offset(10, 0).Resize(RowSize:=SourceRcount - 10)
End With
By directly copying only what you want you avoid the need to delete the rows later.