I'm using an Index to loop through non blank records in another worksheet and pull through 2 values which works fine.
I now need to duplicate these rows so each row appears 4 times with a 3rd column containing the 4 company names (Company1, Commpany2, Company3 and Company4).
We therefore end up with 4 times the number of records as the source sheet which should look like the following:
My current code is:
Sub Address_Raw()
Dim dataBook As Workbook
Dim Address_Raw As Worksheet, Del_Tax As Worksheet
Dim dataSource As Range, dataDest As Range
Dim sourceDataRowCount As Integer, index As Integer
Set dataBook = Application.ThisWorkbook
Set sheetSource = dataBook.Sheets("Address_Raw")
Set sheetDest = dataBook.Sheets("Del_Tax")
Set dataSource = sheetSource.Range("B4", _
sheetSource.Range("B90000").End(xlUp))
sourceDataRowCount = dataSource.Rows.Count
Set dataDest = sheetDest.Range("B13", "B" & _
sourceDataRowCount)
For index = 1 To sourceDataRowCount
dataDest(index, 1).Value = dataSource(index, 1).Value
dataDest(index, 2).Value = dataSource(index, 2).Value
Next index
End Sub
You will have to add an inner loop in the for loop. Something like this (untested):
destIndex = 1
For index = 1 To sourceDataRowCount
For j = 1 to 4
dataDest(destIndex, 1).Value = dataSource(index, 1).Value
dataDest(destIndex, 2).Value = dataSource(index, j + 1).Value
destIndex = destIndex + 1
Next j
Next index
Related
I am new to VBA and i am not able to find any solution to my problem.
I have two workbooks with data. In workbook1 there is a name column A.In workbook2 there is also a name columnA and other data from column B to D. I need to search name from Column A of workbook2 in column A of workbook 1 and if the name matches I need to paste the corresponding rows in workbook1. Also please note that In workbook2 there may be more than one entry for same name.. so in those cases those row values must be concatenated and pasted on workbook1.
Please help
Dim AVals As New Dictionary
Dim k As Long, j As Long, lastRow1 As Long, lastRow2 As Long
Dim sh_1, sh_3 As Worksheet
Dim MyName As String
Dim tmpCollection As Collection
Set sh_1 = Sheets("snipe-sample-assets blank")
Dim key As Variant
inputRowMin = 1
inputRowMax = 288
inputColMin = 1
inputColMax = 9
equipmentCol = 4
dimensionCol = 9
Set equipmentDictionary = CreateObject("Scripting.Dictionary")
equipmentDictionary.CompareMode = vbTextCompare
Set inputSheet = Application.Sheets("Verizon WirelessNumbers_2021033")
Set inputRange = Range(Cells(inputRowMin, inputColMin), Cells(inputRowMax, inputColMax))
Set equipmentCollection = New Collection
For i = 1 To inputRange.Height
thisEquipment = inputRange(i, equipmentCol).Text
nextEquipment = inputRange(i + 1, equipmentCol).Text
thisDimension = inputRange(i, dimensionCol).Text
'The Strings are equal - add thisEquipment to collection and continue
If (StrComp(thisEquipment, nextEquipment, vbTextCompare) = 0) Then
equipmentCollection.Add thisDimension
'The Strings are not equal - add thisEquipment to collection and the collection to the dictionary
Else
equipmentCollection.Add thisDimension
equipmentDictionary.Add thisEquipment, equipmentCollection
Set equipmentCollection = New Collection
End If
Next
'Set sh_3 = Sheets("sheet2")
lastRow2 = sh_1.Range("A:A").Rows.Count
lastRow2 = sh_1.Cells(lastRow2, 2).End(xlUp).Row 'last used row in column 2
'MsgBox lastRow2
For j = 2 To lastRow2
MyName = UCase(sh_1.Cells(j, 2).Value)
For Each key In equipmentDictionary.Keys
If (StrComp(MyName, key, vbTextCompare) = 0) Then
Set tmpCollection = equipmentDictionary.Item(MyName)
For k = 1 To tmpCollection.Count
sh_1.Cells(j, 10).Value = tmpCollection.Item(k)
Next
End If
Next
Next j
Quick run down of what you need
'You declare all these based on where your data resides
sheetName1 = "Sheets1"
sheetName2 = "Sheets2"
wbName1 = activeworkbook.name
wbName2 = activeworkbook.name 'I've included this for where you might want to fork solution to work off two workbooks
'Loop through entries in sheetName1
iRows1 = 1
Do Until IsEmpty(workbooks(wbName1).sheets(sheetName1).cells(iRows1,1))
sourceName = workbooks(wbName1).sheets(sheetName1).cells(iRows1,1)
'Loop through entries in sheetName2
colB = ""
colC = ""
colD = ""
iRows2 = 1
Do Until IsEmpty(workbooks(wbName2).sheets(sheetName2).cells(iRows2,1))
if workbooks(wbName2).sheets(sheetName2).cells(iRows2,1) = sourceName then
'If there is a match then append. If you want to delimit, then you'd need to add in a delimiter & "," for example
colB = colB & workbooks(wbName2).sheets(sheetName2).cells(iRows2,2).text
colC = colC & workbooks(wbName2).sheets(sheetName2).cells(iRows2,3).text
colD = colD & workbooks(wbName2).sheets(sheetName2).cells(iRows2,4).text
end if
iRows2 = iRows2 + 1
Loop
if colB <> "" then
'Found something, send it to sheetName1
workbooks(wbName1).sheets(sheetName1).cells(iRows1,2) = colB
workbooks(wbName1).sheets(sheetName1).cells(iRows1,3) = colC
workbooks(wbName1).sheets(sheetName1).cells(iRows1,4) = colD
end if
iRows1 = iRows1 + 1
Loop
If you want to do it for separate workbooks, then you need to assign a wbName2. My use of ActiveWorkbook assumes it'll be run out of the workbook you are pasting to. It also assumes you've opened both workbooks. You can figure that bit out yourself I'm sure.
I am trying to make an auto scheduling program with an excel.
For example, each number is certain job assigned to the person given day.
1/2 1/3 1/4 1/5
Tom 1 2 2 ?
Justin 2 3 1 ?
Mary 3 3 ?
Sam 1 ?
Check O O X ? ## check is like =if(b2=c2,"O","X")
The things I want to make sure is every person is given a different job from yesterday.
My idea
while
randomly distribute jobs for 1/5
wend CheckCell = "O"
But I found that checking cell in the vba script doesn't work - the cell is not updated in each while loop.
Could you give me a little pointer for these kinds of program? Because I am new to vbaScript, any kinds of help would be appreciated.
Using VBA, I'm sure there are better ways to do this, but this will check the values from the penultimate column against values from last column and if they match it will write "O" to under the last column, else it will write "X":
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
counter = 0 'set counter
For i = 2 To LastRow 'loop through penultimate column and add values to array
If ws.Cells(i, LastCol - 1).Value <> "" Then
Values = Values & ws.Cells(i, LastCol - 1) & ","
End If
Next i
Values = Left(Values, Len(Values) - 1)
Values = Split(Values, ",") 'split values into array
For i = 2 To LastRow 'loop through last column and add values to array
If ws.Cells(i, LastCol).Value <> "" Then
ValuesCheck = ValuesCheck & ws.Cells(i, LastCol) & ","
End If
Next i
ValuesCheck = Left(ValuesCheck, Len(ValuesCheck) - 1)
ValuesCheck = Split(ValuesCheck, ",")
For y = LBound(Values) To UBound(Values) 'loop through both arrays to find all values match
For x = LBound(ValuesCheck) To UBound(ValuesCheck)
If Values(y) = ValuesCheck(x) Then counter = counter + 1
Next x
Next y
If counter = UBound(Values) + 1 Then 'if values match
ws.Cells(LastRow + 1, LastCol).Value = "O"
Else 'else write X
ws.Cells(LastRow + 1, LastCol).Value = "X"
End If
End Sub
just to clarify are you looking to implement the random number in the vba or the check.
To do the check the best way would be to set the area as a range and then check each using the cells(r,c) code, like below
Sub checker()
Dim rng As Range
Dim r As Integer, c As Integer
Set rng = Selection
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
If rng.Cells(r, c) = rng.Cells(r, c + 1) Then
rng.Cells(r, c).Interior.Color = RGB(255, 0, 0)
End If
Next c
Next r
End Sub
this macro with check the text you have selected for the issue and change the cell red if it matches the value to the right.
To make it work for you change set rng = selection to your range and change the rng.Cells(r, c).Interior.Color = RGB(255, 0, 0) to the action you want
A sligthly different approach than the other answers.
Add this function:
Function PickJob(AvailableJobs As String, AvoidJob As String)
Dim MaxTries As Integer
Dim RandomJob As String
Dim Jobs() As String
Jobs = Split(AvailableJobs, ",")
MaxTries = 100
Do
MaxTries = MaxTries - 1
If MaxTries = 0 Then
MsgBox "Could find fitting job"
End
End If
RandomJob = Jobs(Int((1 + UBound(Jobs)) * Rnd()))
Loop Until RandomJob <> AvoidJob
PickJob = RandomJob
End Function
And put this formula in your sheet
=PickJob("1,2,3",D2)
where D2 points to is the previous job
I’m starting with a worksheet “Med” that has formulas/data/formatting in cells A4:P9. I need to copy those cells to cell A10 (6 rows down). I then need to fill in some of the cells from information in another worksheet “Data”. I need to repeat this the same number of times as the count of Data!(A:A) -1 dropping down 6 rows each time I copy the information.
The data that I need to fill in comes from the Sheet "Data" and moves over one column for each copy in Sheet “Med”.
I have the code to make the first copy, but don’t have any idea where to go from here. Looking at the code below the next copy would go to A16 (6 rows down from A10).
The ranges from the worksheet “Med” would also increase by 6 rows and the columns would stay the same.
The ranges from the worksheet “Data” would move over on column and the row numbers would stay the same.
Jordan
Sub Macro1()
Dim wsData As Worksheet
Dim wsMed As Worksheet
Set wsData = Sheets("Data")
Set wsMed = Sheets("Med")
'Copy data set
wsMed.Range("A4:P9").Copy wsMed.Range("A10") 'Set Premium Values
wsMed.Range("M11").Value = wsData.Range("C20").Value
wsMed.Range("M12").Value = wsData.Range("C21").Value
wsMed.Range("M13").Value = wsData.Range("C22").Value
wsMed.Range("M14").Value = wsData.Range("C23").Value 'Set Assumptions
wsMed.Range("L11").Value = wsData.Range("C24").Value
wsMed.Range("L12").Value = wsData.Range("C25").Value
wsMed.Range("L13").Value = wsData.Range("C26").Value
wsMed.Range("L14").Value = wsData.Range("C27").Value
End Sub
This macro runs the code three times
Sub Macro1()
Dim wsData As Worksheet
Dim wsMed As Worksheet
Set wsData = Sheets("Data")
Set wsMed = Sheets("Med")
Dim i As Integer, j As Integer, x As Integer
i = 10
j = 3
'Copy data set
For x = 1 To 3 ' run 3 times
wsMed.Range("A4:P9").Copy wsMed.Cells(i, 1) 'Set Premium Values
wsMed.Range("M" & i + 1).Value = wsData.Cells(20, j).Value
wsMed.Range("M" & i + 2).Value = wsData.Cells(21, j).Value
wsMed.Range("M" & i + 3).Value = wsData.Cells(22, j).Value
wsMed.Range("M" & i + 4).Value = wsData.Cells(23, j).Value 'Set Assumptions
wsMed.Range("L" & i + 1).Value = wsData.Cells(24, j).Value
wsMed.Range("L" & i + 2).Value = wsData.Cells(25, j).Value
wsMed.Range("L" & i + 3).Value = wsData.Cells(26, j).Value
wsMed.Range("L" & i + 4).Value = wsData.Cells(27, j).Value
i = i + 6
j = j + 1
Next x
End Sub
I'm trying to remove the blank records from a combobox with two lists.
This is my code:
Private Sub UserForm_Initialize()
Dim N As Range
Dim LastRow As Integer
Dim ws As Worksheet
PREST.ColumnCount = 2
Set ws = Worksheets("L_Location")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim i, j As Integer
Dim location(2 To 100, 1 To 2) As String
For j = 1 To 2
For i = 2 To LastRow
If ws.Cells(i, j).Value <> vbNullString Then
location(i, j) = ws.Cells(i, j).Value
End If
Next i
Next j
PREST.List = location
End Sub
I don't know what I'm doing wrong.
You are having blanks because your 2D array is already sized with 100 rows. A simple workaround would be to first count the non-empty rows, then dimension the Array accordingly.
Dim location() As String
Dim count As Long
count = Range("A2:A" & LastRow).SpecialCells(xlCellTypeConstants).Cells.count
ReDim location(1 To count, 1 To 2)
'then continue from here to fill the array
This code will fill the combobox with your range value then will delete any empty item:
Private Sub UserForm_Initialize()
Dim LastRow As Long
Dim ws As Worksheet
PREST.ColumnCount = 2
Set ws = Worksheets("L_Location")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim i As Long ', j As Integer
PREST.List = ws.Range("a1:b" & LastRow).Value
For i = PREST.ListCount - 1 To 0 Step -1
If PREST.List(i) = "" Then PREST.RemoveItem i
Next
End Sub
I tried this :
Dim location() As String
ReDim location(LastRow - 2, 1)
For j = 0 To 1
For i = 0 To LastRow - 2
If ws.Cells(i + 2, j + 1).Value <> vbNullString And ws.Cells(i + 2, j + 1).Value <> "" Then
location(i, j) = ws.Cells(i + 2, j + 1).Value
End If
Next i
Next j
PREST.List = location
which seems to work but i guess its gonna give me an error if the list is empty (lastrow = 1)
Since you say that any two cells on the same row are both either blank or with values, then you could go like follows:
Dim cell As Range
Dim i As Long, j As Long
PREST.ColumnCount = 2
With Worksheets("L_Location") '<--| reference your worksheet
With .Range("A2", .Cells(.Rows.Count,1).End(xlUp)).SpecialCells(xlCellTypeConstants) '<--| reference its column A not empty cells from row 1 down to last not empty one
Dim location(1 To .Count, 1 To 2) As String '<--| size your array rows number to that of referenced cells
For Each cell In .Cells '<--| loop through referenced cells
i = i + 1 '<--| update array row index
For j = 1 To 2 '<--| loop through array columns
location(i, j) = cell.Offset(j -1).Value '<--| fill array
Next j
Next cell
End With
End With
PREST.List = location
I have an excel table that has some duplicates and we currently have a count of these however I want to populate a unique number for each duplicate. e.g.
Number Count Sequence
1 2 1
1 2 1
2 3 2
2 3 2
2 3 2
3 4 3
3 4 3
3 4 3
3 4 3
4 2 4
4 2 4
5 5 5
5 5 5
5 5 5
5 5 5
5 5 5
I was playing with the following IF statement but I want it to check through the whole range and check if it has any in a wrong order but still the same.
=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0))
is this possible?
It will add the unique ref into the a Column which is 3 columns up from what every you set col equal to.
It also requires that col + 3 to be blank, this will make the checking easier.
Sub SomeSub()
Dim Array1 As Variant
Dim Array2 As Variant
With ActiveSheet.UsedRange
LastRow = .Rows(.Rows.Count).Row
End With
'Setting up the array for assigning each row value to the array
ReDim Array1((LastRow + 1))
ReDim Array2((LastRow + 1))
'Here youwill set what column is the "Number" Column
col = 1
'Assigning the row data into the arrays
'Starting at 2 to skip the title row
For r = 2 To LastRow
'Values in Column 1 go to Array1
Array1(r) = Cells(r, col)
'Values in Column 2 go to Array2
Array2(r) = Cells(r, col + 1)
Next r
'Setting unquie ref to 1
Seq = 1
'Running through each row of data
For i = 2 To LastRow
'col + 3 refers to a column on beyond the Sequence colum
'If the column is blank then that row has not been checked yet
If Cells(i, col + 3) = "" Then
'Assign the Uniqui ref to the row
Cells(i, col + 3).Value = Seq
'Running through the rest of the rows to check if they are like the current row
For n = i + 1 To (LastRow)
'If cell is blank then the row has been checked
If Cells(n, col + 3) = "" Then
'Array(i) is the current row
'Array(n) are the leading rows after row i
'If the current row is the same as any leading row then the uniquie ref = seq
If Array1(i) = Array1(n) And Array2(i) = Array2(n) Then Cells(n, col + 3).Value = Seq
'Else a value has been added
Else
'Do nothing
End If
Next n
'Increment the seq
Seq = Seq + 1
'Ending the If Cells(i, col + 3) = "" Then
End If
Next i
End Sub
You can first loop through the column and get the unique items using collections.
This part of the code:
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
Will only get the unique items, as a collection of items cannot have duplicates.
Use this to Number the duplicates.Change the sheet name as required.
Sub NumberDupes()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim LstRw As Long
Dim c As Long, clr As Long, x, r As Range
Set sh = Sheets("Sheet2")
With sh
.Columns("B:B").ClearContents
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1))
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 1
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For c = 1 To LstRw
Set r = .Cells(c, 1)
x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r)
If r = vNum Then
If x > 1 Then
r.Offset(, 1) = clr
End If
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
Use this to Color the Duplicates, this will work on a small scale, depends on how many unique items there are, it's cool example though. Edited code from my answer here.
Sub ColorDupes()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim LstRw As Long
Dim c As Long, clr As Long, x, r As Range
Set sh = Sheets("Sheet2")
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1))
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 3
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For c = 1 To LstRw
Set r = .Cells(c, 1)
x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r)
If r = vNum Then
If x > 1 Then
r.Interior.ColorIndex = clr
End If
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
In C1 just 1 and in C2:
=MIN(IF(($A$2:A2=A3)*($B$2:B2=B3),$D$2:D2,MAX($D$2:D2)+1))
This is an array formula and must be confirmed with Ctrl+Shift+Enter.
and simply autofill down from C3
hmm... i think i got it wrong :/
if only looking at Column A then this should be enough:
=MIN(IF($A$2:A2=A3,$D$2:D2,MAX($D$2:D2)+1))
This is an array formula and must be confirmed with Ctrl+Shift+Enter.
looking at your formula it can be shortened:
=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0))
'IF(A2=A1,TRUE,FALSE)=FALSE ==>> A1<>A2
=IF(IF(A1<>A2,1,0)>=0,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0))
'IF(A1<>A2,1,0)>=0 ==>> TRUE
=IF(TRUE,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0))
'IF(TRUE => allways true
=IF(A1<>A2,1,0)+D1
'last skip
=D1+(A1<>A2)