Goal
I would like to loop through five sheets and populate a dropdown list in a sixth sheet based on some requirements.
Problem
I don't know how to populate the dropdown list, make them dynamic and loop through the five sheets.
Description
In the sixth sheet (Dropdown Sheet), column E contains names which I would like to compare to the first row (E1:GG1) in the five sheets. Each column has a bunch of 1's.
If there is a match between a name in column E (Dropdown Sheet) and a name in a row (one of the five sheets) AND there's a '1' in the column for that row, the dropdown list should be populated with the ID in column A.
Desired output
Code
Private Sub ValuesInDropdownList()
Dim TeamSource As Range, PersonSource As Range, r As Range, csString As String
Dim PersonCell As Range, TeamCell As Range
Dim Dropdown As Collection
Dim i As Integer
Dim lastRow As Integer
Set TeamSource = Sheets("Dropdown Sheet").Range("E10:E100")
Set PersonSource = Sheets("Sheet1").Range("E1:GG1")
Set Dropdown = New Collection
On Error Resume Next
For Each PersonCell In PersonSource
v = PersonCell.Value
Debug.Print (v)
With PersonSource
lastRow = .Cells(.Rows.Count, PersonCell.Columns.Count).End(xlUp).Row
Debug.Print (lastRow)
End With
If v <> "" Then
For Each TeamCell In TeamSource
Debug.Print (TeamCell)
If PersonCell = TeamCell Then
intValueToFind = 1
For i = 1 To lastRow
If PersonCell.Offset(i, 0) = intValueToFind Then
Debug.Print (PersonCell.Offset(i, -4))
Dropdown.Add v, CStr(v)
End If
Next i
End If
Next TeamCell
End If
Next PersonCell
End Sub
Related
I have a set of x names (in row 4) with corresponding dates (row 3) (the combination of name and date is unique).
I would like to copy the unique name and date, and then paste it x times (where x is the total number of names) in a different sheet.
I would like the code to loop through all names and dates and paste them within column A,B in a new sheet. Where column A has heading name and column B has heading date.
Initial data:
After Code:
What I have attempted so far - i can't seem to get the paste correct
Sub Test()
Dim o As Variant
Dim CountC_Range As Range
Dim cel_3 As Range
Dim MyRange As Range
'count the number of different engagement areas
Worksheets("Sheet8").Activate
Range("B4").Select
Set CountC_Range = Range("B4", Selection.End(xlToRight))
'Set the letter k as number of engagements as we'll use this later
o = WorksheetFunction.CountA(CountC_Range) - "1"
Worksheets("sheet9").Activate
Range("A1").Select
MyRange = Range("Selection.End(xlDown) + 1", "Selection.End(xlDown) + o + 1")
For Each cel_3 In Worksheets("Sheet8").Range("4:4")
If cel_3.Value <> "" Then
MyRange = cel_3.Value
End If
Next cel_3
End Sub
There are plenty of ways to do it, but having this input:
The code below will provide this:
Sub TestMe()
With Worksheets("Source")
Dim k As Long
k = .Range("A4").End(xlToRight).Column
End With
With Worksheets("Target")
Dim i As Long, ii As Long
Dim currentRow As Long
For i = 1 To k
For ii = 1 To k
currentRow = currentRow + 1
.Cells(currentRow, "A") = Worksheets("Source").Cells(3, i)
.Cells(currentRow, "B") = Worksheets("Source").Cells(4, i)
Next
Next
End With
End Sub
Dependencies:
Name the input worksheet "Source"
Name the output worksheet "Target"
A must read - How to avoid using Select in Excel VBA
I'm wondering if its possible to create a VBA that map a random "numerical codes" from an excel Spreadsheet 2 (let's say column A) to a column B (Spreadsheet 1).
Some of the values on the spreadsheet 2 are repeated, I would like to build a unique correspondence (no repeated values from column A / Spreadsheet 2 to my column B / Spreadsheet 1)
Spreadsheet1:
Spreadsheet2
Desired output, column filled from Spreadsheet2 (Unique)values :
Is this possible?? feasible??
The following VBA code uses for loops to iterate through the list of values in Spreadsheet2 and only copy each value to Spreadsheet1 if the value has not occurred already in the list.
Option Explicit
Sub ListUniqueCodes()
Dim code As Long
Dim codes As Range
Dim i As Integer
Dim j As Integer
Dim last_row As Integer
Dim output_cell As Range
Dim unique_codes As New Collection 'You could also use a Scripting.Dictionary here as suggested by JvdV
'See https://stackoverflow.com/questions/18799590/avoid-duplicate-values-in-collection
'Store the length of the list of codes that is in Spreadsheet2:
last_row = Workbooks("Spreadsheet2.xlsx").Sheets("Sheet1").Range("A1").End(xlDown).Row
'Store the list of codes that is in Spreadsheet2:
Set codes = Workbooks("Spreadsheet2.xlsx").Sheets("Sheet1").Range("A1:A" & last_row)
'For each code...
For i = 1 To codes.Rows.Count
code = codes.Cells(i).Value2
'...if it does not equal zero...
If code <> 0 Then
'...and if it is not already in the collection unique_codes...
For j = 1 To unique_codes.Count
If unique_codes(j) = code Then Exit For
Next j
'...then add it to the collection unique_codes:
If j = (unique_codes.Count + 1) Then
unique_codes.Add code
End If
End If
Next i
Set output_cell = Workbooks("Spreadsheet1.xlsm").Sheets("Sheet1").Range("B2")
'Write out the unique codes in Spreadsheet1:
For i = 1 To unique_codes.Count
output_cell.Offset(i - 1, 0).Value2 = unique_codes(i)
Next i
End Sub
I working on a sheet that looking up the value in column D and compares that value to another sheet in another workbook to see if it is in there as well. If the value is in the other sheet then the loop moves to the next cell in column D. If it is not, then I want to highlight the row of which that value is located but only the cells that contain information (A:CU). I cannot seem to get it right.
The code I have so far highlights the row of the cell where the value was not found in the other sheet. The problem is it highlights the entire row. I know this is because of the .EntireRow but I am not sure how to only highlight the the cells I need.
Sub check()
Dim i As Integer
Dim k As Integer
Dim j As Integer
Dim Sheet1 As Worksheet
Dim WorkingTab As Worksheet
Dim PerDay24 As Workbook
Dim CurrentOrderCalendar As Workbook
Set Sheet1 = Worksheets("Sheet1")
Set PerDay24 = Sheet1.Parent
Set CurrentOrderCalendar = Workbooks.Open("M:\Projects\D9#s Purging\Current Order Calendar - Copy.xlsx")
Set WorkingTab = Worksheets("working tab")
k = Sheet1.UsedRange.Rows.Count
j = WorkingTab.UsedRange.Rows.Count
For i = 2 To k
If Application.WorksheetFunction.CountIf(WorkingTab.Range(WorkingTab.Cells(2, 1), WorkingTab.Cells(j, 1)), Sheet1.Cells(i, 4).Value) > 0 Then
Sheet1.Cells(i, 100).Value = "Active"
Else
Sheet1.Rows(i).EntireRow.Interior.Color = 65535
End If
Next i
End Sub
I expect for the code to highlight columns A:CU on row i when the IF statement is false.
I would like to write a VBA macro for excel through which i want data from a master sheet to populated to another sheets conditionally.
for example, my master sheet ("Sheet1) has multiple rows and column. The condition for data population from Sheet1 to Sheet2 should be based on these condition
(1) Only rows which has a particular string in a column (say "keyword" string in column D)
(2) Only few columns to be copied from Sheet1 to Sheet2 (say column A,B,E & G)
I have a code that copies a column when the heading of the column is a certain string, would that help?
Edit1:
Here is what I have come up with. The code should be flexible enough to adapt to any type of spreadsheet you've got
Dim keyColumn As Integer
Dim i As Integer
Dim keyWord As Variant 'I've used variant, so you can choose your own data type for the keyword
Dim dataSh As String 'I'm using sheet names for sheet referencing
Dim populateSh As String
Dim rowNum As Integer
Dim dataRow() As Variant
Sub Populate()
'set the column number, which contains the keywords, the keyword itself,
'name of the sheet to populate and the row offset you'd like to start populating
populateSh = "populate"
keyColumn = 4
keyWord = "yes"
rowNum = 0
'assuming you run the macro in the sheet you get the data from, get its name to return to it after copying the row
dataSh = ActiveSheet.Name
'loop through all the used cells in the column
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, keyColumn) = keyWord Then
'starting in row 1 in the sheet you populate, you'll have to set the rowNum variable to desired offset few lines above
rowNum = rowNum + 1
Call copyRow(i, rowNum)
End If
Next i
End Sub
Sub copyRow(ByVal cRow As Integer, ByVal pRow As Integer)
Dim colNum As Integer
'set the number of columns you'd like to copy
colNum = 3
'redimension the array to carry the data to other sheet
'this can be done any way you,d like, but I'm using array for flexibility
ReDim dataRow(1 To colNum)
'put the data into the array, as an example I'm using columns 1, 2 and 3, while skipping the keyword column.
dataRow(1) = Cells(cRow, 1)
dataRow(2) = Cells(cRow, 2)
dataRow(3) = Cells(cRow, 3)
Sheets(populateSh).Select
For p = 1 To UBound(dataRow)
Cells(pRow, p) = dataRow(p)
Next p
Sheets(dataSh).Select
End Sub
Hope that helps. Sorry for any style errors in advance
I have been trying to create a simple macro that takes all duplicate records from a source sheet and pastes them into a new sheet.
I have been messing around, and the closest I've gotten is the creation of a list that extracts all duplicate values except for the first duplicate value in a cluster.
So for example, if a list looks like this below:
1
1
2
3
4
5
1
The sheet with the duplicates will list:
1
1
It will consider the first instance of '1' as unique, and that is totally not what I want. I want it to show every single instance of the duplicated row, so I awnt this:
1
1
1
Here's what I do to deal with duplicates. It isn't a macro, but works for me:
Sort the column with the duplicate. (For this example, say column C)
In a new column, write an IF function. Eg in cell D5: =if(c5=c4,1,"")
Copy cell D5 to the entire list.
Copy and paste value column D over itself. Eg in step 2, the formula is replaced with a "1"
Sort column D
Any row with a 1 is a duplicate. Do as you wish!
You can also do things like find the sum of column D (shows me how many duplicates)
After clarifications by OP the following procedure will perform as required:
Sub CopyDuplicates()
'***************************************************************
'** This proc expects you to select all the cells in a single **
'** column that you want to check for duplicates in. If dup- **
'** licates are found, the entire row will be copied to the **
'** predetermined sheet. **
'***************************************************************
Dim ShO As Worksheet
Dim Rng1 As Range
Dim pRow As Integer
Dim c As Range, cTmp As Range
Dim found
Dim Addresses() As String
Dim a() As String
Dim p2 As Integer
Dim tfFlag As Boolean, sTmp As Variant
Set ShO = Worksheets("Sheet2") 'You can change this to whatever worksheet name you want the duplicates in
Set Rng1 = Application.Selection 'Rng1 is all the currently selected cells
pRow = 1 'This is the first row in our outpur sheet that will be used to record duplicates
ReDim a(0) 'Initialize our array that holds found values
For Each c In Rng1.Cells 'Cycle through each cell in our selected range
ReDim Addresses(0) 'This array holds the cell address for our duplicates.
'We will reset the array each time we move to the next cell
'Now check the array of already found duplicates.
'If the current value is already there skip to next value
tfFlag = False
For Each sTmp In a
If CStr(c.Value) = sTmp Or CStr(c.Value) = "xXDeleteXx" Then 'We've already done this value, move on
tfFlag = True
Exit For
End If
Next
If Not tfFlag Then 'Remember the flag is true when we have already located the
'duplicates for this value, so skip to next value
With Rng1
Set found = .Find(c.Value, LookIn:=xlValues) 'Search entire selected range for value
If Not found Is Nothing Then 'Found it
Addresses(0) = found.Address 'Record the address we found it
Do 'Now keep finding occurances of it
Set found = .FindNext(found)
If found.Address <> Addresses(0) Then
ReDim Preserve Addresses(UBound(Addresses) + 1)
Addresses(UBound(Addresses)) = found.Address
End If
Loop While Not found Is Nothing And found.Address <> Addresses(0) 'Until we get back to the original address
If UBound(Addresses) > 0 Then 'We Found Duplicates
a(UBound(a)) = c.Value 'Record the value we found a duplicate for in an array
ReDim Preserve a(UBound(a) + 1) 'add an empty spot to the array for next value
ShO.Range("A" & pRow).Value = "Duplicate Rows for Value " & c.Value & _
" in Column " & c.Column & " on original sheet" 'Add a label row
pRow = pRow + 1 'Increment to the next row
For p2 = UBound(Addresses) To 0 Step -1 'Cycle through the duplicate addresses
Set cTmp = Rng1.Worksheet.Range(Addresses(p2)) 'we just want to easily get the correct row to copy
Rng1.Worksheet.Rows(cTmp.Row).Copy ShO.Rows(pRow) 'Copy form orig to duplicates sheet
cTmp.Value = "xXDeleteXx" 'Mark for Delete the original row
pRow = pRow + 1 'Increment row counter
Next p2
pRow = pRow + 1 'This increment will give us a blank row between sets of dupicates
End If
End If
End With
End If
Next
'Now go delete all the marked rows
Do
tfFlag = False
For Each c In Rng1
If c.Value = "xXDeleteXx" Then
Rng1.Worksheet.Rows(c.Row).Delete (xlShiftUp)
tfFlag = True
End If
Next
Loop Until tfFlag = False
End
End Sub