Delete Duplications When Importing - vba

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.

Related

AutoFilter Delete only works when Macro is run from a specific sheet

I have this Macro which essentially uses two sheets - sheet2 updates sheet1 and then kills the second worksheet.
I noticed that when it comes to one part of the macro (delete row which has "Delete" in column A in worksheet 1) it doesn't appear to work if I run the Macro from worksheet 2. If I run it from Sheet 1 is works without a problem.
This is the full code, just in case you need to look at it - I'll highlight the part that I'm having trouble with next.:
Public Sub Cable_Load_full()
'~~> Copy New Accounts from worksheet2
Dim ws1 As Worksheet, ws2 As Worksheet
Dim bottomL As Integer
Dim x As Integer
Dim c As Range
Dim i As Long, J As Long, LastCol As Long
Dim ws1LR As Long, ws2LR As Long
Dim ws1Rng As Range, aCell As Range
Dim SearchString
Set ws1 = Sheets("CableSocials")
Set ws2 = Sheets("CableRevised")
bottomL = ws2.Range("A" & Rows.Count).End(xlUp).Row: x = 1
x = ws1.Range("A" & Rows.Count).End(xlUp).Row
x = x + 1
For Each c In ws2.Range("A1:A" & bottomL)
If c.Value = "New" Then
c.EntireRow.Copy ws1.Range("A" & x)
x = x + 1
End If
Next c
'~~> Assuming that ID is in Col B
'~~> Get last row in Col B in Sheet1
ws1LR = ws1.Range("B" & Rows.Count).End(xlUp).Row
'~~> Set the Search Range
Set ws1Rng = ws1.Range("B1:B" & ws1LR)
'~~> Adding Revise Column to worksheet 1
ws1.Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Value = "Revise"
Set ws2 = Sheets("CableRevised")
'~~> Turn off Filter
ws2.AutoFilterMode = False
'~~> Get last row in Col A in Sheet2
ws2LR = ws2.Range("B" & Rows.Count).End(xlUp).Row
'~~> Loop through the range in Sheet 2 to match it with the range in Sheet1
For i = 1 To ws2LR
SearchString = ws2.Range("B" & i).Value
'~~> Search for the ID
Set aCell = ws1Rng.Find(What:=SearchString, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> If found
If Not aCell Is Nothing Then
'~~> Append values
ws1.Cells(aCell.Row, 1).Value = ws2.Cells(i, 1).Value
ws1.Cells(aCell.Row, 3).Value = ws2.Cells(i, 2).Value
ws1.Cells(aCell.Row, 19).Value = ws2.Cells(i, 18).Value
ws1.Cells(aCell.Row, 20).Value = ws2.Cells(i, 19).Value
End If
Next i
'~~> Delete the accounts that need to be deleted
ws1.AutoFilterMode = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, "Delete"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
ws1.AutoFilterMode = False
'~~> Removing New from Column B
ws1.Columns("B").Replace What:="New", _
Replacement:="", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
ws1.Columns("A").EntireColumn.Delete
Call SheetKiller
End Sub
Sub SheetKiller()
Dim s As Worksheet, t As String
Dim i As Long, K As Long
K = Sheets.Count
For i = K To 1 Step -1
t = Sheets(i).Name
If t = "CableRevised" Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
End If
Next i
End Sub
So the part that only works when I run the Macro from Sheet1 is:
'~~> Delete the accounts that need to be deleted
ws1.AutoFilterMode = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, "Delete"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
ws1.AutoFilterMode = False
I'm not sure why - is it acting as if it will only delete the rows from the ActiveSheet (which I guess would be the Sheet I run the Macro from?) ? Is it possible to make it work even if I run the Macro from Sheet2?
Thanks for any help you provide!
You need to explicitly refer to ranges on ws1. As written, your code is looking for ranges on the active sheet.
Try this:
'~~> Delete the accounts that need to be deleted
ws1.AutoFilterMode = False
With ws1.Range("A1", ws1.Range("A" & ws1.Rows.Count).End(xlUp))
.AutoFilter 1, "Delete"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
ws1.AutoFilterMode = False

Avoiding code repetition by including both conditions of If-else in a function

I have a code with an If-yes and an If-no condition. The first few lines for each condition are different, while the rest of it is the exact same and performs the same operation. Can anyone point out as to how I can incorporate the part of the code that is exactly same in a function that can be called in either condition?
I am not well versed as to how I could move ahead with this. Any help would be appreciated. Thank you.
This is my code:
Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
fromRange.Copy
toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "%
completed"
DoEvents
End Sub
Sub Automate_Estimate()
Dim MyFile As String, Str As String, MyDir As String, DestWb As Workbook,
SrcWb As Workbook
Dim Rws As Long, Rng As Range
Dim DestName As String
Dim SourceName As String
Dim completed As Double
Dim flg As Boolean, sh As Worksheet
Dim ref As Long
'Dim DestRowCount As Long
Dim DestColCount As Long
Dim lnCol As Long
Dim last As Long
Dim destKey As String, sourceKey As String
Dim destTotalRows As Long
Dim i As Integer, j, k As Integer
Dim DestSheet As Worksheet
Dim SrcSheet As Worksheet
DestName = "x" 'Name of destination sheet
SourceName = "y" 'Name of Source sheet
MyDir = "\Path\"
'Default directory path"
Const steps = 22 'Number of rows copied
ref = 13 'row in y sheet in which 'Grand Total' is present
Set DestWb = ThisWorkbook 'Setting Destination workbook
' disable certain excel features to speed up the process
Application.DisplayAlerts = False
'Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim answer As Integer
answer = MsgBox("If you want to select a specific file click Yes, if you
want to go to default path, click No",vbYesNo + vbQuestion, "User Specified Path")
If answer = vbYes Then
MyFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
completed = 0
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
Set SrcWb = Workbooks.Open(MyFile, UpdateLinks:=0) 'Opening the Source workbook
(REPETITIVE CODE STARTS HERE)
completed = 0
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
'Find the last non-blank cell in row ref
lnCol = SrcWb.Sheets(SourceName).Cells(ref, Columns.Count).End(xlToLeft).Column
last = lnCol - 1 'To get penultimate column
Set DestSheet = DestWb.Sheets(DestName)
Set SrcSheet = SrcWb.Sheets(SourceName)
destTotalRows = DestSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Finding last non-blank cell in Column 1 in Destination sheet
'MsgBox "Last row is: " & destTotalRows
For i = 1 To destTotalRows
destKey = DestSheet.Cells(i, 1)
If destKey = "" Then GoTo endFor 'Ignoring blanks while looping through destination sheet
sourceKey = GetSourceKey(destKey)
If sourceKey = "" Then GoTo endFor 'Ignoring unmatched values while looping through source sheet
Debug.Print "DestKey", destKey, "SourceKey", sourceKey
k = DestSheet.Cells(1, 1).EntireColumn.Find(What:=destKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Destkey in Destination sheet
j = SrcSheet.Cells(1, 2).EntireColumn.Find(What:=sourceKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Srckey in Source sheet
Debug.Print j, k
Call CopyRange(SrcSheet.Range(Cells(j, 3), Cells(j, 3).End(xlToRight)), DestSheet.Cells(k, 2), completed) 'Copying the data from Source sheet and pasting it onto destiation sheet
completed = completed + (100 / steps)
endFor:
Next i
SrcWb.Close
Application.StatusBar = "Copying is complete"
DoEvents
ElseIf answer = vbNo Then
'change the address to suit
MyFile = Dir(MyDir & "Estimate*.xls*") 'change file extension
ChDir MyDir
Set SrcWb = Workbooks.Open(MyDir + MyFile, UpdateLinks:=0)
(REPETITIVE CODE STARTS HERE)
completed = 0
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
'Find the last non-blank cell in row ref
lnCol = SrcWb.Sheets(SourceName).Cells(ref, Columns.Count).End(xlToLeft).Column
last = lnCol - 1 'To get penultimate column
Set DestSheet = DestWb.Sheets(DestName)
Set SrcSheet = SrcWb.Sheets(SourceName)
destTotalRows = DestSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Finding last non-blank cell in Column 1 in Destination sheet
'MsgBox "Last row is: " & destTotalRows
For i = 1 To destTotalRows
destKey = DestSheet.Cells(i, 1)
If destKey = "" Then GoTo endFor 'Ignoring blanks while looping through destination sheet
sourceKey = GetSourceKey(destKey)
If sourceKey = "" Then GoTo endFor 'Ignoring unmatched values while looping through source sheet
Debug.Print "DestKey", destKey, "SourceKey", sourceKey
k = DestSheet.Cells(1, 1).EntireColumn.Find(What:=destKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Destkey in Destination sheet
j = SrcSheet.Cells(1, 2).EntireColumn.Find(What:=sourceKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Srckey in Source sheet
Debug.Print j, k
Call CopyRange(SrcSheet.Range(Cells(j, 3), Cells(j, 3).End(xlToRight)), DestSheet.Cells(k, 2), completed) 'Copying the data from Source sheet and pasting it onto destiation sheet
completed = completed + (100 / steps)
endFor:
Next i
SrcWb.Close
Application.StatusBar = "Copying is complete"
DoEvents
MyFile = Dir()
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ActiveSheet.DisplayPageBreaks = True
End Sub
basic coding principle is DRY -> Don't Repeat Yourself ;)
so move the resused code outside If clause, keeping there only the part where you decide which file to open
like so:
Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
fromRange.Copy
toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% "
completed ""
DoEvents
End Sub
Sub Automate_Estimate()
Dim MyFile As String, Str As String, MyDir As String, DestWb As Workbook, SrcWb As Workbook
Dim Rws As Long, Rng As Range
Dim DestName As String
Dim SourceName As String
Dim completed As Double
Dim flg As Boolean, sh As Worksheet
Dim ref As Long
'Dim DestRowCount As Long
Dim DestColCount As Long
Dim lnCol As Long
Dim last As Long
Dim destKey As String, sourceKey As String
Dim destTotalRows As Long
Dim i As Integer, j, k As Integer
Dim DestSheet As Worksheet
Dim SrcSheet As Worksheet
DestName = "x" 'Name of destination sheet
SourceName = "y" 'Name of Source sheet
MyDir = "\Path\"
'Default directory path"
Const steps = 22 'Number of rows copied
ref = 13 'row in y sheet in which 'Grand Total' is present
Set DestWb = ThisWorkbook 'Setting Destination workbook
' disable certain excel features to speed up the process
Application.DisplayAlerts = False
'Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim answer As Integer
answer = MsgBox("If you want to select a specific file click Yes, if you want to go to default path, click No", vbYesNo + vbQuestion, "User Specified Path")
If answer = vbYes Then
MyFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
completed = 0
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
Set SrcWb = Workbooks.Open(MyFile, UpdateLinks:=0) 'Opening the Source workbook
ElseIf answer = vbNo Then
'change the address to suit
MyFile = Dir(MyDir & "Estimate*.xls*") 'change file extension
ChDir MyDir
Set SrcWb = Workbooks.Open(MyDir + MyFile, UpdateLinks:=0)
End If
completed = 0
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
'Find the last non-blank cell in row ref
lnCol = SrcWb.Sheets(SourceName).Cells(ref, Columns.Count).End(xlToLeft).Column
last = lnCol - 1 'To get penultimate column
Set DestSheet = DestWb.Sheets(DestName)
Set SrcSheet = SrcWb.Sheets(SourceName)
destTotalRows = DestSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Finding last non-blank cell in Column 1 in Destination sheet
'MsgBox "Last row is: " & destTotalRows
For i = 1 To destTotalRows
destKey = DestSheet.Cells(i, 1)
If destKey = "" Then GoTo endFor 'Ignoring blanks while looping through destination sheet
sourceKey = GetSourceKey(destKey)
If sourceKey = "" Then GoTo endFor 'Ignoring unmatched values while looping through source sheet
Debug.Print "DestKey", destKey, "SourceKey", sourceKey
k = DestSheet.Cells(1, 1).EntireColumn.Find(What:=destKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Destkey in Destination sheet
j = SrcSheet.Cells(1, 2).EntireColumn.Find(What:=sourceKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Srckey in Source sheet
Debug.Print j, k
Call CopyRange(SrcSheet.Range(Cells(j, 3), Cells(j, 3).End(xlToRight)), DestSheet.Cells(k, 2), completed) 'Copying the data from Source sheet and pasting it onto destiation sheet
completed = completed + (100 / steps)
endFor:
Next i
SrcWb.Close
Application.StatusBar = "Copying is complete"
DoEvents
MyFile = Dir()
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ActiveSheet.DisplayPageBreaks = True
End Sub

VBA: Trying to consolidate all worksheets into one new worksheet in single workbook

I am trying to copy all worksheets, one at a time, and pasting into a new worksheet. These files come from multiple third parties so the worksheets can vary. I'm running into a problem below when trying to determine last row Lrow and last column Lcol because an error appears saying Object doesn't support this property or method. I do plan on submitting this to my work so any help with error proofing or general macro tips are appreciated.
Sub ws_copy()
Dim Lrow As Long
Dim Lcol As Long
Dim Pasterow As Long
Dim WSCount As Integer
Dim i As Integer
'On Error Resume Next
'Application.DisplayAlerts = False
i = Application.InputBox(prompt:="Enter the place order of first tab to be copied.", Title:="Worksheet Consolidation", Type:=1)
If IsEmpty(i) = True Then
Exit Sub
Else
If IsNumeric(i) = False Then
MsgBox "Enter a numeric value."
Else
If IsNumeric(i) = True Then
Worksheets.Add(before:=Sheets(1)).Name = "Upload"
WSCount = Worksheets.Count
For i = i + 1 To WSCount
Lrow = Worksheets(i).Find("*", After:=Cells(1, 1), _
LookIn:=xlFormulas, _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Lcol = Worksheets(i).Find("*", After:=Cells(1, 1), _
LookIn:=xlFormulas, _
Lookat:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Pasterow = Lrow + 1
Workbook.Worksheets(i).Range(Cells(1, 1), Cells(Lrow, Lcol)).Copy
Workbook.Worksheets("Upload").Cells(Pasterow, 1).Paste
Next i
Else
Exit Sub
End If
End If
End If
'On Error GoTo 0
'Application.DisplayAlerts = False
End Sub
A common way to find the last row/column is:
With Worksheets(i)
Lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
hth
Based on the comment that:
I can't assume any one column or row has the last piece of data because of the variety of the files received.
You should look at using the UsedRange property of the Worksheet (MSDN). UsedRange expands as more data is entered onto the worksheet.
Some people will avoid using UsedRange because if some data has been entered, and then deleted then UsedRange will include these 'empty' cells. The UsedRange will update itself when the workbook is saved. However, in your case, it doesn't sound like this is a relevant issue.
An example would be:
Sub Test()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim rngSource As Range
Dim rngTarget As Range
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
Set rngSource = wsSource.UsedRange
rngSource.Copy Destination:=wsTarget.Cells
End Sub
Here is a method of finding the last used row and last used column in a worksheet. It avoids the issues with UsedRange and also your issues of not knowing which row might have the last column (and which column might have the last row). Adapt to your purposes:
Option Explicit
Sub LastRowCol()
Dim LastRow As Long, LastCol As Long
With Worksheets("sheet1") 'or any sheet
If Application.WorksheetFunction.CountA(.Cells) > 0 Then
LastRow = .Cells.Find(what:="*", after:=[A1], _
LookIn:=xlFormulas, _
searchorder:=xlByRows, _
searchdirection:=xlPrevious).Row
LastCol = .Cells.Find(what:="*", after:=[A1], _
LookIn:=xlFormulas, _
searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
Else
LastRow = 1
LastCol = 1
End If
End With
Debug.Print LastRow, LastCol
End Sub
Although the basic technique has been long used, Siddarth Rout, some time ago, posted a version adding COUNTA to account for the case where the worksheet might be empty -- a useful addition.
If you want to merge data on each sheet into one MasterSheet, run the script below.
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:G1")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
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
Also, see the link below for some other options to do this slightly differently.
http://www.rondebruin.nl/win/s3/win002.htm

Form Data to Particular Cells

In Excel sheet2 i have Columns A & D for Name, B & E Start Date and column C & F is End Date and a Form with ComboBox (loaded with names) and two Textboxes.
I want when I click submit button it will search the columns for a name that matches the ComboBox value and then write the values of the two TextBoxes into the right adjacent two EMPTY cells
Private Sub CommandButton4_Click()
Dim irow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
With ws
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Me.Combo.Value
.Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = Me.sttdate.value
.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Value = Me.enddate.Value
End With
With Me
.Combo.Value = ""
.startdate.Value = ""
.enddate.Value = ""
End With
End Sub
This code is adding value of all form into Columns A B & C
This should do the trick. I added some checks based on what you wrote in your explanation in case it helps.
Private Sub CommandButton4_Click()
Dim irow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
With ws
irow = .Range("A" & .Rows.Count).End(xlup).Row
Dim rFound as Range
Set rFound = .Range("A1:A" & iRow).Find(Me.Combo.Value, lookat:=xlWhole)
If not rFound is Nothing Then
If IsEmpty(rFound.Offset(,1)) and IsEmtpy(rFound.Offset(,2)) Then
rFound.Offset(,1) = Me.sttdate.value
rFound.Offset(,2) = Me.enddate.value
With Me
.Combo.Value = ""
.startdate.Value = ""
.enddate.Value = ""
End With
Else
Msgbox "Name already has values"
End If
Else
Msgbox "Name not Found"
End If
End Sub
This should work just fine :
Private Sub CommandButton4_Click()
Dim irow As Long, _
wS As Worksheet, _
NextRow As Long, _
cF As Range
Set wS = Worksheets("Sheet2")
With wS
With .Range("A:A")
'First, define properly the Find method
Set cF = .Find(What:=Me.Combo.Value, _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
End With
'If there is a result, keep looking with FindNext method
If Not cF Is Nothing Then
If cF.Offset(0, 1) <> vbNullString Then
Set cF = cF.End(xlToRight).Offset(0, 1)
cF.Value = Me.sttdate.Value
cF.Offset(0, 1).Value = Me.EndDate.Value
Else
.Cells(cF.Row, "B").Value = Me.sttdate.Value
.Cells(cF.Row, "C").Value = Me.EndDate.Value
End If
Else
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
.Cells(NextRow, "A").Value = Me.Combo.Value
.Cells(NextRow, "B").Value = Me.sttdate.Value
.Cells(NextRow, "C").Value = Me.EndDate.Value
End If
End With
With Me
.Combo.Value = ""
.StartDate.Value = ""
.EndDate.Value = ""
End With
End Sub

Input data from master file to multiple worksheets selecting a specific sheet for each

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.