The answer "How to find duplicates and list them separately using VBA in Excel?" is exactly what I am looking for. I need help editing the language to fit my spreadsheet. Any help is greatly appreciated. I am not a programmer, just an enduser who admires the power of VBA. Thank you.
I've tried to edit the syntax but i cannot get it work in my spreadsheet.
Sub find_dups()
' Create and set variable for referencing workbook
Dim wb As Workbook
Set wb = ThisWorkbook
' Create and set variable for referencing worksheet
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
' Find current last rows
' For this example, the data is in column A and the duplicates are in column C
Dim lngLastRowME As Long
lngLastRowME = ws.Range("A29-7834-9-0003").End(xlUp).Row
Dim lngLastRowDups As Long
lngLastRowDups = ws.Range("C29-7834-9-0003").End(xlUp).Row
' Create and set a variable for referencing data range
Dim rngME As Range
Set rngME = ws.Range("a4:a" & lngLastRowME)
Dim lngRowCount As Long
lngRowCount = 0
Dim clME As Variant
Dim lngCount As Long
Dim lngRowIndexME As Long
Dim lngRowIndexDups As Long
lngRowIndexDups = lngLastRowDups + 1
' Variable to store those values we've already checked
Dim strAlreadySearched As String
For Each clME In rngME.Cells
' Reset variables
lngCount = 0
' See if we've already searched this value
If InStr(1, strAlreadySearched, "|" & clME.Value & "|") = 0 Then
' We haven't, so proceed to compare to each row
For lngRowIndexME = 1 To lngLastRowME
' If we have a match, count it
If rngME.Cells(lngRowIndexME, 1).Value = clME.Value Then
lngCount = lngCount + 1
End If
Next lngRowIndexME
' If more than 1 instance
If lngCount > 1 Then
' Dup's were found, fill in values under duplicates
ws.Cells(lngRowIndexDups, 3).Value = clME.Value
ws.Cells(lngRowIndexDups, 4).Value = lngCount
' Drop down a row
lngRowIndexDups = lngRowIndexDups + 1
' Capture this value so we don't search it again
strAlreadySearched = strAlreadySearched & "|" & clME.Value & "|"
End If
End If
Next clME
End Sub
runtime error 400
Screen Shot and Workbook
Related
I am trying to populate a combo box using an arraylist. I used the following code but it doesn't seem to work.
Private Sub UserForm_Initialize()
Sheets("MSS").Select
Dim counter As Integer
Dim cmbox_opt As String
Dim array_cmbox As ArrayList
Set array_cmbox = New ArrayList
Dim last_row As Integer
Dim i As Integer
last_row = Range("B" & Rows.Count).End(xlUp).Row
For counter = 3 To last_row
cmbox_opt = Range("B" & counter).Value
If Not array_cmbox.Contains(cmbox_opt) Then
array_cmbox.Add cmbox_opt
End If
Next
For i = 1 To i = 1 + i
If array_cmbox.Contains(array_cmbox(i)) Then
Me.ComboBoxArea.AddItem array_cmbox(i)
End If
Next
'Ensure Window Dimensions'
With Me
.Width = 577
.Caption = "Master Sanitation Schedule Form v.1.0"
.Height = 274
End With
End Sub
However, if I just add the line
Me.ComboBoxArea.AddItem array_cmbox(2)
It does add the second item to the combo box from the ArrayList
Populate a Combo Box Using an Array List
Private Sub UserForm_Initialize()
PopulateComboBoxArea
'Ensure Window Dimensions'
With Me
.Width = 577
.Caption = "Master Sanitation Schedule Form v.1.0"
.Height = 274
End With
End Sub
Private Sub PopulateComboBoxArea()
' Define constants.
Const wsName As String = "MSS"
Const FirstRow As Long = 3
Const Col As String = "B"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Calculate the last row ('LastRow'),
' the row of the last non-empty cell in the column.
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If FirstRow > LastRow Then Exit Sub
' Reference the one-column range ('crg').
Dim crg As Range
Set crg = ws.Range(ws.Cells(FirstRow, Col), ws.Cells(LastRow, Col))
' Write the number of rows to a variable ('rCount').
Dim rCount As Long: rCount = crg.Rows.Count
' Write the values from the (one-column) range
' to a 2D one-based (one-column) array ('cData').
Dim cData() As Variant
If rCount = 1 Then ' one cell
ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
Else ' multiple cells
cData = crg.Value
End If
' Create and reference a new array list.
' Either early binding: needs a reference to 'mscorlib.dll'...
'Dim arl As ArrayList: Set arl = New ArrayList
' ... or late binding: no reference needed
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
' IMO, this would be the way to go since when using early binding,
' the Intellisense, that would be useful to easily learn how to use
' the array list, doesn't work at this moment.
' Declare additional variables.
Dim r As Long ' Current Array Row
Dim cString As String ' Current Array Value Converted to a String
' Loop through the rows of the array...
For r = 1 To rCount
' Write the value converted to a string to a variable ('cString').
cString = CStr(cData(r, 1))
' Check if the string doesn't exist in the array list.
If Not arl.Contains(cString) Then ' string is not in the array list...
arl.Add cString ' ... so add it
'Else ' string is already in the array list; do nothing
End If
Next r
' IMO, a huge disadvantage, compared to the dictionary, is that
' you cannot compare the strings case-insensitively when using 'Contains'.
' When using a dictionary you could simply use
' e.g. dict.CompareMode = vbTextCompare' making e.g. 'A = a'.
' IMO, one of the very few reasons to use an array list over a dictionary
' is that you can easily sort it:
arl.Sort
' Populate the combo box with the values from the array list
' (no need to loop).
Me.ComboBoxArea.List = arl.ToArray
End Sub
I am copying data under columns with matching headers between the source sheet and the destination sheet. Both the sheets are in the same excel file but they need to have a clarification number.
For example, one of the columns in the destination sheet has the the clarification number QM6754 and the row of data of QM6754. The source sheet also has the clarification number column but I dont want to copy it, I want to copy the other data in the row of this specific clarification number to the destination sheet that in one of its columns. this way the data isn't copied randomly and the entire row from each sheet relate to each other.
The code I used shows results(I modified it) but when I run it, the excel file shows (not responding) for about 3-4 minutes and then shutsdown or leaves a blank Excel sheet and VBA window. I close the excel file and reopen it and the data has been copied. The file is quite large and I have three pushbuttons that run this code for each sheet I want to copy data from. Three sheets with average of 3k-6k rows. But I cannot eliminate the rows.
The code runs but I would like to optimize of the way it runs because it isn't practical to run, close file and then open file again. Could the issue be with the For loop?
Sub CopyColumnData()
Dim wb As Workbook
Dim myworksheet As Variant
Dim workbookname As String
' DECLARE VARIABLES
Dim i As Integer ' Counter
Dim j As Integer ' Counter
Dim colsSrc As Integer ' PR Report: Source worksheet columns
Dim colsDest As Integer ' Open PR Data: Destination worksheet columns
Dim rowsSrc As Long ' Source worksheet rows
Dim WsSrc As Worksheet ' Source worksheet
Dim WsDest As Worksheet ' Destination worksheet
Dim ws1PRRow As Long, ws1EndRow As Long, ws2PRRow As Long, ws2EndRow As Long
Dim searchKey As String, foundKey As String
workbookname = ActiveWorkbook.Name
Set wb = ThisWorkbook
myworksheet = "Sheet 1 copied Data"
wb.Worksheets(myworksheet).Activate
' SET VARIABLES
' Source worksheet: Previous Report
Set WsSrc = wb.Worksheets(myworksheet)
Workbooks(workbookname).Sheets("Main Sheet").Activate
' Destination worksheet: Master Sheet
Set WsDest = Workbooks(workbookname).Sheets("Main Sheet")
'Adjust incase of change in column in both sheets
ws1ORNum = "K" 'Clarification Number
ws2ORNum = "K" 'Clarification Number
' Setting first and last row for the columns in both sheets
ws1PRRow = 3 'The row we want to start processing first
ws1EndRow = WsSrc.UsedRange.Rows(WsSrc.UsedRange.Rows.Count).Row
ws2PRRow = 3 'The row we want to start search first
ws2EndRow = WsDest.UsedRange.Rows(WsDest.UsedRange.Rows.Count).Row
For i = ws1PRRow To ws1EndRow ' first and last row
searchKey = WsSrc.Range(ws1ORNum & i)
'if we have a non blank search term then iterate through possible matches
If (searchKey <> "") Then
For j = ws2PRRow To ws2EndRow ' first and last row
foundKey = WsDest.Range(ws2ORNum & j)
' Copy result if there is a match between PR number and line in both sheets
If (searchKey = foundKey) Then
' Copying data where the rows match
WsDest.Range("AI" & j).Value = WsSrc.Range("A" & i).Value
WsDest.Range("AJ" & j).Value = WsSrc.Range("B" & i).Value
WsDest.Range("AK" & j).Value = WsSrc.Range("C" & i).Value
WsDest.Range("AL" & j).Value = WsSrc.Range("D" & i).Value
WsDest.Range("AM" & j).Value = WsSrc.Range("E" & i).Value
WsDest.Range("AN" & j).Value = WsSrc.Range("F" & i).Value
WsDest.Range("AO" & j).Value = WsSrc.Range("G" & i).Value
WsDest.Range("AP" & j).Value = WsSrc.Range("H" & i).Value
Exit For
End If
Next
End If
Next
'Close Initial PR Report file
wb.Save
wb.Close
'Pushbuttons are placed in Summary sheet
'position to Instruction worksheet
ActiveWorkbook.Worksheets("Summary").Select
ActiveWindow.ScrollColumn = 1
Range("A1").Select
ActiveWorkbook.Worksheets("Summary").Select
ActiveWindow.ScrollColumn = 1
Range("A1").Select
End Sub
To increase the speed and reliability, you will want to handle the copy/paste via array transfer instead of the Range.Copy method. Given your existing code, here's how a solution that should work for you:
Sub CopyColumnData()
'Source data info
Const sSrcSheet As String = "Sheet 1 copied Data"
Const sSrcClarCol As String = "K"
Const lSrcPRRow As Long = 3
'Destination data info
Const sDstSheet As String = "Main Sheet"
Const sDstClarCol As String = "K"
Const lDstPRRow As Long = 3
'Set variables based on source and destination
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = ThisWorkbook
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Worksheets(sSrcSheet)
Dim wbDst As Workbook: Set wbDst = ActiveWorkbook
Dim wsDst As Worksheet: Set wsDst = wbDst.Worksheets(sDstSheet)
On Error GoTo 0
'Verify source and destination were found
If wsSrc Is Nothing Then
MsgBox "Worksheet """ & sSrcSheet & """ not found in " & wbSrc.Name
Exit Sub
End If
If wsDst Is Nothing Then
MsgBox "Worksheet """ & sDstSheet & """ not found in " & wbDst.Name
Exit Sub
End If
'Setup variables to handle Clarification Number matching and data transfer via array
Dim hDstClarNums As Object: Set hDstClarNums = CreateObject("Scripting.Dictionary") 'Clarification Number Matching
'Load Source data into array
Dim rSrcData As Range: Set rSrcData = wsSrc.Range(sSrcClarCol & lSrcPRRow, wsSrc.Cells(wsSrc.Rows.Count, sSrcClarCol).End(xlUp))
Dim aSrcClarNums() As Variant: aSrcClarNums = rSrcData.Value
Dim aSrcData() As Variant: aSrcData = Intersect(rSrcData.EntireRow, wsSrc.Columns("A:H")).Value 'Transfer data from columns A:H
'Prepare dest data array
Dim rDstData As Range: Set rDstData = wsDst.Range(sDstClarCol & lDstPRRow, wsDst.Cells(wsDst.Rows.Count, sDstClarCol).End(xlUp))
Dim aDstClarNums() As Variant: aDstClarNums = rDstData.Value
Dim aDstData() As Variant: aDstData = Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value 'Destination will be into columns AI:AP
'Use dictionary to perform Clarification Number matching
Dim vClarNum As Variant
For Each vClarNum In aDstClarNums
If Not hDstClarNums.Exists(vClarNum) Then hDstClarNums.Add vClarNum, hDstClarNums.Count + 1
Next vClarNum
'Transfer data from source to destination using arrays
Dim i As Long, j As Long
For i = 1 To UBound(aSrcClarNums, 1)
For j = 1 To UBound(aSrcData, 2)
If hDstClarNums.Exists(aSrcClarNums(i, 1)) Then aDstData(hDstClarNums(aSrcClarNums(i, 1)), j) = aSrcData(i, j)
Next j
Next i
'Output to destination
Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value = aDstData
'Save and close source workbook (uncomment next line if this is necessary)
'wbSrc.Close SaveChanges:=True
'Activate summary sheet, cell A1 in destination workbook (uncomment these lines if this is necessary)
'wbDst.Worksheets("Summary").Activate
'wbDst.Worksheets("Summary").Range("A1").Select
End Sub
There are 24 sheets in this workbook. I need to copy the same range from 23 sheets and paste them in a final sheet called "ALL SURVEY". Is there any way to code it in such a way that I don't need to write so much code as I did in the following macro?
Sheets("2").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E2").*PasteSpecial xlPasteValues*
Sheets("3").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E3").*PasteSpecial xlPasteValues*
Sheets("4").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E4").*PasteSpecial xlPasteValues*
Sheets("5").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E5").*PasteSpecial xlPasteValues*
It will be much appreciated if you help me get through this hard task
Thank you
You can use a For...Next loop for this:
Sub Tester()
Dim n As Long, c As Range
Set c = ThisWorkbook.Sheets("ALL SURVEY").Range("E2") 'first destination cell
'loop through sheets
For n = 2 To 23
'convert n to string to get the correct sheet
' Sheets("2") vs Sheets(2) - by sheet Name vs. Index
With ThisWorkbook.Sheets(CStr(n)).Range("U3:X3")
c.Resize(.Rows.Count, .Columns.Count).Value = .Value 'set values
Set c = c.Offset(1, 0) 'next destination
End With
Next n
End Sub
You can do something like this:
Sub copyPaste()
Dim survey_sheet As Worksheet, count As Long
count = 1 'start pasting from this row
For Each survey_sheet In ThisWorkbook.Sheets
If survey_sheet.Name <> "ALL SURVEY" Then
survey_sheet.Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E" & count).PasteSpecial xlPasteValues
count = count + 1
End If
Next survey_sheet
End Sub
As you can see in the macro above, there is a loop For all the sheets in the Workbook. It will end when it has gone through every single one.
The If statement is to avoid copy/pasting in the final sheet ant the count variable is for pasting in the next empty row on "ALL SURVEY" sheet.
Copy Ranges by Rows
Adjust the values in the constants section. Pay attention to the Exceptions List. I added those two 'funny' names just to show that you have to separate them by the Delimiter with no spaces. The list can contain non-existing worksheet names, but it won't help, so remove them and add others if necessary.
You can resize the 'copy' range as you desire (e.g. U3:X5, Z7:AS13). The result will be each next range below the other (by rows).
Basically, the code will loop through all worksheets whose names are not in the Exceptions List and will write the values of the given range to 2D one-based arrays in an Array List. Then it will loop through the arrays of the Array List and copy the values to the resulting Data Array whose values will then be copied to the Destination Range.
The Code
Option Explicit
Sub copyByRows()
Const dstName As String = "ALL SURVEY"
Const dstFirst As String = "E2"
Const srcRange As String = "U3:X3"
Const Delimiter As String = ","
Dim ExceptionsList As String
ExceptionsList = dstName & Delimiter & "Sheet500,Sheet1000"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim dst As Worksheet: Set dst = wb.Worksheets(dstName)
Dim srCount As Long: srCount = dst.Range(srcRange).Rows.Count
Dim cCount As Long: cCount = dst.Range(srcRange).Columns.Count
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, Delimiter)
Dim ws As Worksheet
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
arl.Add ws.Range(srcRange).Value
End If
Next ws
Dim Data As Variant: ReDim Data(1 To arl.Count * srCount, 1 To cCount)
Dim Item As Variant
Dim i As Long
Dim j As Long
Dim k As Long
For Each Item In arl
For i = 1 To srCount
k = k + 1
For j = 1 To cCount
Data(k, j) = Item(i, j)
Next j
Next i
Next Item
dst.Range(dstFirst).Resize(k, cCount).Value = Data
End Sub
My code is working when I just use a single workbook and communicate between sheets but gives me subscript out of range errors and object not defined errors when I attempt to reference a cell range in a sheet contained in a different work book. Right now, the error is occurring at "Set pidat = Worksheets("pidat")
Dim pival As Double
'Dim eom As Worksheet 'declaring pidat worksheet as variable
'Set eom = Worksheets("EOM") 'declaring eom worksheet as variable
'Set Inv_Level = Worksheets("Inv_Levels")
Dim pidat As Worksheet 'declaring eom worksheet as variable
Set pidat = Worksheets("pidat")
Dim steve As Workbook
Set steve = Application.Workbooks("EOM Report VBA")
Dim EOMAs As Workbook
Set EOMAs = Application.Workbooks("EOMA")
Dim Inv_Level As Worksheet
'These changes allow for a dynamic range to be referenced outside of the active sheet/workbook
Dim location As String
Dim rownum As Long
Dim loopy As Long
Dim fRng As Range
Dim J As Long
Dim rn As Date
Dim last As Date
Dim rnm As Integer
Dim lastm As Integer
Dim tyear As Long
Dim K As Long
With pidat
J = .Range("J2").Value
rn = Now
last = .Range("B1").Value
rnm = month(rn)
lastm = month(last)
tyear = year(rn)
If lastm < rnm Then
.Range("B1") = (rnm & "/" & "01" & "/" & tyear & " 07:30")
J = J + 100
.Range("J2") = J
End If
End With
K = J + 100
'names of workbook/sheet referenced
With steve
rownum = .Range("E" & Rows.Count).End(xlUp).Row 'counts the number of rows in the location tag column
For loopy = 3 To rownum 'Data values start after row 3, loops through each row in the column
If .Range("E" & loopy) <> "" Then
location = .Range("E" & loopy)
'newloc = location
With Inv_Level
Set fRng = .Cells.Range("A" & J, "ZZ" & K).Find(What:=location, LookIn:=xlFormulas, LookAt:=xlPart) 'eom can be any sheet you need to perform the .Find again
End With
If Not fRng Is Nothing Then
fRng.Offset(0, -1) = pidat.Range("D" & loopy)
Else: End If
'if the search item is not found, do nothing, go to next loop
End If
Next loopy
End With
End Sub
You need to qualify the specific workbook you want to work with.
The line Set pidat = Worksheets("pidat") will fail if the active workbook at the time this line is executed has no worksheet named pidat.
Here is an example of how to qualify a workbook
Dim theWorkbook as Workbook
Set theWorkbook = Application.Workbooks("myWorkbook")
Dim pidat as Worksheet
Set pidat = theWorkbook.Worksheets("pidat")
You could go one step further and verify that a sheet named pidat (or whatever) exists in the qualified workbook, but I'll leave you to discover how to do that :)
Currently I have a template which is in range called rngP1.
And this contains a text below:
"This is to confirm that strTitle has been enacted on strDate for strCompany."
Basically, I have a data in another sheet that will be used to replace these 3 strings from my template:
So what I would like to happen is that in every row data it will search strings strTitle, strDate, and strCompany and replace them according to the data of each row.
I have a code already, however, it doesn't work as I expected:
Sub example()
Dim wsMain As Worksheet
Set wsMain = Sheets("Main")
Dim wsTemplate As Worksheet
Set wsTemplate = Sheets("Template")
Dim textToReplace As Variant
Dim array_example()
Dim Find_Text As Variant
Dim str As String
last_row = wsMain.Range("A1").End(xlDown).Row 'Last row of the data set
ReDim array_example(last_row - 1, 2)
Find_Text = Array("strTitle", "strDate", "strCompany")
str = wsTemplate.Range("rngP1").Value
'Storing values in the array
For i = 0 To last_row - 1
array_example(i, 0) = wsMain.Range("A" & i + 2)
array_example(i, 1) = wsMain.Range("C" & i + 2)
array_example(i, 2) = wsMain.Range("D" & i + 2)
Next
For i = LBound(array_example, 1) To UBound(array_example, 1)
For j = LBound(array_example, 2) To UBound(array_example, 2)
For a = 0 To UBound(Find_Text)
str = Replace(str, Find_Text(a), array_example(i, j))
Next a
Next j
MsgBox str
Next i
End Sub
Wrong Output:
It should be:
This is to confirm that Title1 has been enacted on 13-October-18 for Company X.
And next one would be the next row which is title 2. So on and so fort.
If you have an alternative way to do it, I appreciate it.
Here is a working example:
You can push the data range from a worksheet into an array with one line without looping
DataArr = wsMain.Range("A2:D" & LastRow).Value
You need only 2 loops for the replacing:
one to loop through the data rows
one to loop through the variables to replace
Your template str was not initialized within the loop, but you need a fresh template for every data row.
Note that the array loaded from the range starts counting from 1 but the variables array starts counting from 0.
Option Explicit
Sub Example()
Dim Template As String
Template = "This is to confirm that strTitle has been enacted on strDate for strCompany."
'load your template string from worksheet here!
Dim Variables As Variant 'variables to be replaced
Variables = Array("strTitle", "strDate", "strCompany")
Dim wsMain As Worksheet
Set wsMain = ThisWorkbook.Worksheets("Main")
Dim LastRow As Long 'this method is more reliable to find the last used row
LastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
Dim DataArr As Variant 'load the complete data range into an array
DataArr = wsMain.Range("A2:D" & LastRow).Value
Dim Output As String
Dim iRow As Long, iVar As Long
For iRow = LBound(DataArr, 1) To UBound(DataArr, 1) '1 to LastRow
Output = Template 'initialize with the template!
For iVar = LBound(Variables) To UBound(Variables) ' 0 to 2
Output = Replace(Output, Variables(iVar), DataArr(iRow, iVar + 1))
Next iVar
Debug.Print Output
Next iRow
End Sub