I am trying to create a program that deletes all rows without information in columns B-G and then rearranges the data from a vertical orientation to a horizontal one.
The data is only in columns A-G arranged so that every couple rows (the number is not constant), a row of dates appears. I want every row with dates to be pasted horizontally from each other and all of the data in between the dates to move corresponding with their dates (including column A).
The part that deletes empty rows works well. However, as I tried to write the rearrangement program, I kept on getting an
"Object Required"
error that appeared in the sub line (AKA the first line). Can someone help me resolve this issue? The code is pasted below.
Sub MovingDeletion()
Set rngRange = Selection.CurrentRegion
lngNumRows = rngRange.Rows.Count
lngFirstRow = rngRange.Row
lngLastRow = lngFirstRow + lngNumRows - 1
columns("B").Select
lngCompareColumn1 = ActiveCell.Column
columns("C").Select
lngCompareColumn2 = ActiveCell.Column
columns("D").Select
lngCompareColumn3 = ActiveCell.Column
columns("E").Select
lngCompareColumn4 = ActiveCell.Column
columns("F").Select
lngCompareColumn5 = ActiveCell.Column
columns("G").Select
lngCompareColumn6 = ActiveCell.Column
columns("A").Select
lngCompareColumn7 = ActiveCell.Column
Set MedicationRow = 0
'Deletion Code (Works Fine)
For lngCurrentRow = lngLastRow To lngFirstRow Step -1
Mrow = True
If (Cells(lngCurrentRow, lngCompareColumn1).Text = "" And Cells(lngCurrentRow, lngCompareColumn2).Text = "" And Cells(lngCurrentRow, lngCompareColumn3).Text = "" And Cells(lngCurrentRow, lngCompareColumn4).Text = "" And Cells(lngCurrentRow, lngCompareColumn5).Text = "" And Cells(lngCurrentRow, lngCompareColumn6).Text = "") Then _
Rows(lngCurrentRow).Delete
'Rearrangement Code (Does not work. Gives Object Requiered error)
Dim counter As Integer
Dim NextRow As Integer
Dim i As Integer
i = lngCurrentRow
counter = 0
Number = 0
If (Cells(lngCurrentRow, lngCompareColumn7).Text <> "Days") Then
counter = counter + 1
If counter > 1 Then
NextRow = lngCurrentRow - 1
While (Cells(NextRow, lngCompareColumn7).Text <> "Days")
NextRow = NextRow - 1
Number = Number + 1
Wend
End If
Range("A" & CStr(i) & ":G" & CStr(NextRow)).Cut Range("H1" & CStr(i) & ":P" & CStr(NextRow))
End If
Next lngCurrentRow
End Sub
Related
I have gone crazy with vba projects around the house and helping my wife upping her reports to the next level. I’m having troubles putting down to VBA what I’m thinking. If anyone has felt my pain please shed some light on the actual script that would help me over this hump. Summary might be comparing cell value for certain text using InStr and if doesn't exist the appending characters to the right end. I can append and run thru one cycle of the loop but get confused with trying to write the logic I'm thinking.
Alittle background on the report: One row equals one reservation. Within that row there is a column labeled “Nights”. This column is filtered for any reservation with more than “1” Night. Example: could be 3 nights, 6 nights, and 10 nights doesn’t matter. I have a macro that sorts these reservations and splits the one reservation into multiple rows totaling the number value in the “Nights” column. Basically, copying and inserting the rows next to each other. While this filtered is still applied (SpecialVisibleCells Only). Now I have another column labeled “ResNumber”. With 3, 6, or 10 rows split out the “ResNumber” column is the same number. I’m tasked with walking down this ‘ResNumber” column and appending a “-1” for the first row. A “-2” for the second reservation “-3” for the third and possibly a forth “-4” Until the last row of the copied for that one reservation group. Then the cycle (loop) starts again on the next group or block of rows. Same procedure.
Dim lnrow As Integer
Dim llrow As String
Dim rownuml As Integer 'row checker
Dim colnuml As String 'column checker
Dim count As Integer
Dim total As String 'Value of reservation's "Nights" column Offset(,17)
Dim startnum As Integer 'Start number for counter
Dim actcell As String 'Activecell
startnum = 1
With sh
llrow = .Cells(.Rows.count, 2).End(xlUp).row
If llrow = "" Then Exit Sub
.Cells(2, 2).Resize(llrow - 1).SpecialCells(xlCellTypeVisible).Select
For lnrow = 2 To llrow
rownuml = ActiveCell.row
colnuml = ActiveCell.Column
total = ActiveCell.offset(, 17).Value
For count = 1 To total
rownuml = ActiveCell.row
colnuml = ActiveCell.Column
actcell = ActiveCell.Value
'Compares row 1 and checks resNumber value for "-1" if none exist it appends.
If InStr(ActiveCell.Value, "-1") = 0 Then
ActiveCell.Value = ActiveCell.Value & "-1"
Else
GoTo nexrow
End If
'Compares row 2 and checks resNumber value of above cell.
If InStr(ActiveCell.offset(-1, 0).Value, "-1") = 0 Then
Resume Next
If InStr(ActiveCell.Value, "-2") = 0 Then
ActiveCell.Value = ActiveCell.Value & "-2"
GoTo nexrow
End If
'to jump out of loop nexrow
'ActiveCell moves one row down.
ActiveCell.offset(1, 0).SpecialCells(xlCellTypeVisible).Select
rownuml = ActiveCell.row 'just checking row number
colnuml = ActiveCell.Column 'just checking column number
'since 1st reservation is already in the DB startnum starts at # 1. The counter
startnum = startnum + count
Next count
Next
End With
Try:
Option Explicit
Sub test()
Dim LastRow As Long, Times As Long, Counter As Long, i As Long, y As Long
Dim strNumber As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 2 To LastRow
strNumber = .Range("B" & i).Value
Times = Application.WorksheetFunction.CountIf(.Range("B2:B" & LastRow), strNumber)
If Times > 1 Then
Counter = 1
For y = 2 To LastRow
If strNumber = .Range("B" & y).Value Then
.Range("B" & y).Value = strNumber & " - " & Counter
.Range("D" & y).Value = 1
Counter = Counter + 1
End If
Next y
End If
Next i
End With
End Sub
Results:
I am trying to identify a specific range in column-A and concatenate two cells within the specific range and delete the empty cell. I have been successful in putting a code together and it does the job very well. But, I don't know how to loop it to identify next range. Any help would be appreciated.
As per below image and code, First, I am finding and selecting a range between two (MCS) in column-A with a condition that, if the rows are more than 8 between two MCS. Then I am concatenating first 2 cells immediately after MCS and delete the empty row.
The below code works well for first range but I am unable to loop to identify next range from row 22 to 32 and perform concatenations.
I dont know how to loop in column-A and select ranges and concatenate. Any help would be much appreciated. Thanks
Sub MergeStem()
Dim findMCS1 As Long
Dim findMCS2 As Long
Dim myCount As Integer
Dim myStems As Long
Dim mySelect As Range
Dim c As Range
findMCS1 = Range("A:A").Find("MCS", Range("A1")).Row
findMCS2 = Range("A:A").Find("MCS", Range("A" & findMCS1)).Row
myCount = Range("A" & findMCS1 + 1 & ":A" & findMCS2 - 1).Cells.Count
Range("B1").Value = myCount
MsgBox "Number of rows =" & myCount
Set mySelect = Selection
If myCount > 8 Then
myStems = Range("A" & findMCS1 + 2 & ":A" & findMCS2 - 9).Select
Set mySelect = Selection
For Each c In mySelect.Cells
If firstcell = "" Then firstcell = c.Address(bRow, bCol)
sArgs = sArgs + c.Text + " "
c.Value = ""
Next
Range(firstcell).Value = sArgs
End If
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Can you try this? Ordinarily, Find would be the way to go but because you are deleting rows it's hard to keep track of which cells you've found.
Sub x()
Dim r As Long, n1 As Long, n2 As Long
With Range("A1", Range("A" & Rows.Count).End(xlUp))
For r = .Count To 1 Step -1
If .Cells(r).Value = "MCS" Then
If n1 = 0 Then
n1 = .Cells(r).Row
Else
n2 = .Cells(r).Row
End If
If n1 > 0 And n2 > 0 Then
If n1 - n2 > 9 Then
.Cells(r + 1).Value = .Cells(r + 1).Value & .Cells(r + 2).Value
'.Cells(r + 2).EntireRow.Delete
'Call procedure to delete row
End If
n1 = n2
n2 = 0
End If
End If
Next r
End With
End Sub
I am very new to coding with it, and what appears below probably looks quite horrible.
What this code currently does is do an instr search for all 3 required values appearing in a single, and absolutely defined (for test purposes), row of another table, in a separate worksheet. Copies the A cell value from that row, pastes it into the cell next to the source table row, currently being searched, and colour codes it with a green fill.
What I want it to do, is be aware that there is a whole other table of data in the other worksheet, and have it search row by row for all 3 required values matching in a given row.
Once it gets an exact hit, I want it to output the A cell value for the row that has been confirmed to be a match of all 3 required values.
The table in the other sheet is dynamic, in that it increases or decreases in total number of rows day be day.
Is anyone kind enough to be able to help me with this?
Now, here is my novice mishmash of code:
Private Sub Match_Click()
Dim i As Integer, row As Integer, narrative1 As String, transDate As Date,
amount As Double, result As String
row = 2
i = 1
narrative1 = Worksheets("Sheet2").Range("D" & row)
transDate = Worksheets("Sheet2").Range("B" & row)
amount = Worksheets("Sheet2").Range("J" & row)
Do While Cells(i, 1).Value <> ""
If narrative1 > "" Then
If InStr(1, UCase(Worksheets("Sheet1").Range("D22")), UCase(narrative1)) And
InStr(1, Worksheets("Sheet1").Range("B22"), transDate) And InStr(1,
Worksheets("Sheet1").Range("H22"), amount) Then
result = Worksheets("Sheet1").Range("A3").Value
Else
result = ""
End If
End If
i = i + 1
If Worksheets("Sheet2").Range("A" & row).Value = "" Then result = ""
Worksheets("Sheet2").Range("K" & row).Value = result
If result <> "" Then Worksheets("Sheet2").Range("K" & row).Interior.Color =
RGB(198, 224, 180)
If Worksheets("Sheet2").Range("A" & row).Value = "" Then
Worksheets("Sheet2").Range("K" & row).Interior.ColorIndex = xlNone
row = row + 1
narrative1 = Worksheets("Sheet2").Range("D" & row)
transDate = Worksheets("Sheet2").Range("B" & row)
amount = Worksheets("Sheet2").Range("J" & row)
Loop
End Sub
I think the following code will do what you expect, I've commented it to let you know what its doing (I haven't tested it, but I'm pretty sure it will do the job):
Private Sub Match_Click()
Dim i As Long 'These should be Long instead of Integer, as Excel has more cells than Integer has values.
Dim row As Long
Dim LastRow As Long
Dim LastRow2 As Long
Dim narrative1 As String
Dim transDate As String
Dim amount As Double
Dim result As String
Dim val1 As Integer
Dim val2 As Integer
Dim val3 As Integer
LastRow2 = Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, "A").End(xlUp).row 'get the lastrow of Sheet2
LastRow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, "A").End(xlUp).row 'get the lastrow of Sheet1
For i = 1 To LastRow2 'loop from row 1 to last on Sheet2
narrative1 = Worksheets("Sheet2").Range("D" & i) 'get the variables to compare
transDate = Worksheets("Sheet2").Range("B" & i)
amount = Worksheets("Sheet2").Range("J" & i)
For x = 1 To LastRow ' loop through row 1 to last on Sheet1
If narrative1 <> "" Then
val1 = InStr(Worksheets("Sheet1").Cells(x, 4).Value, narrative1) 'number 4 represents column D
val2 = InStr(Worksheets("Sheet1").Cells(x, 2).Value, transDate) 'number 2 represents column B
val3 = InStr(Worksheets("Sheet1").Cells(x, 8).Value, amount) 'number 8 represents column H
If val1 > 0 And val2 > 0 And val3 > 0 Then 'if all three have been found
result = Worksheets("Sheet1").Cells(x, 1).Value 'get result
Worksheets("Sheet2").Range("K" & LastRow2 + 1).Value = result 'paster result into next free row on Sheet2 column K
If Worksheets("Sheet2").Cells(x, 1).Value <> "" Then Worksheets("Sheet2").Range("K" & LastRow2 + 1).Interior.ColorIndex = 4
Else
result = ""
End If
End If
Next x
Next i
End Sub
first time poster, long time reader.
Apologies if this is hard to follow.
I have a spreadsheet which has a list of first names and last names. What I am wanting to do is take all of the first names which have the same last name and place them, evenly(ish) and separated by a comma, into the 3 reference columns in the same spreadsheet for example;
Example of Completed Sheet
I would like to do this in VBA because there are 200+ names and growing, and later the code will use this information to create and populate more workbooks.
So far, what I have works for all last names which have 3 or less first names (ie; one per column) but I cannot get it to work for last names where there are more than 3 first names.
My thought was to read all of the names into an array, split out the elements which have more than 3 names into another array, join these together separated by a comma, to then be transferred to the relevant column on the sheet.
However for some reason, I cannot get it to output more than one name into the column.
I have had a few attempts at this, but this is my latest attempt;
Private Sub cmdUpdate_Click()
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
Dim namesPerCol As Long
Dim strLastNameMatches As String
Dim arrNames() As String
Dim arrMultiNames(3) As String
Application.ScreenUpdating = False
With ActiveSheet
'Finds the last row with data in it
lngLastRow = .Cells(.Rows.count, "A").End(xlUp).Row
End With
'Sort the Columns
Columns("A:E").Sort key1:=Range("A1"), Header:=xlYes
'Loop through the LastNames
For i = 2 To lngLastRow
'Second loop through the LastNames
For j = 2 To lngLastRow
'If the last name matches
If Cells(i, 2).Value = Cells(j, 2).Value Then
'If the cell is empty then
If Range("C" & i).Value = "" Then
'Place the name in colA into colC
Range("C" & i).Value = Range("A" & j).Value
Else
'If the cell is not empty, then place a comma and space and then the value from colA
Range("C" & i).Value = Range("C" & i).Value & ", " & Range("A" & j).Value
End If
End If
Next j
Next i
For i = 2 To lngLastRow
strLastNameMatches = Range("C" & i).Value
arrNames = Split(strLastNameMatches, ", ")
If UBound(arrNames) > 2 Then
namesPerCol = UBound(arrNames) / 3
For l = 0 To 1
For k = LBound(arrNames) To namesPerCol
arrMultiNames(l) = arrNames(k) & ", "
Next k
Next l
For m = LBound(arrMultiNames) To UBound(arrMultiNames)
Select Case m
Case 0
Range("C" & i).Value = arrMultiNames(m)
Case 1
Range("D" & i).Value = arrMultiNames(m)
Case 2
Range("E" & i).Value = arrMultiNames(m)
End Select
Next m
Else
For j = LBound(arrNames) To UBound(arrNames)
Select Case j
Case 0
Range("C" & i).Value = arrNames(j)
Case 1
Range("D" & i).Value = arrNames(j)
Case 2
Range("I" & i).Value = arrNames(j)
End Select
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
Apologies for the poor quality coding, I will work on tiding it up once it is all working.
Any help I can get to get this code splitting out the names evenly across the three columns will be greatly appreciated
This task might be simpler if you could store your data into a more tree-like structure. There are many ways to do this; I've used the Collection object as it's easy to handle an unknown number of items. Basically, there are collections within a collection, ie one collection of first names for each last name.
The sample below uses very rudimentary distribution code (which is also hard-coded to a split of 3), but the point is that iterating through and down the tree is far simpler:
Dim lastList As Collection, firstList As Collection
Dim lastText As String, firstText As String
Dim data As Variant, last As Variant, first As Variant
Dim output() As Variant, dist(1 To 3) As Long
Dim str As String
Dim r As Long, c As Long, i As Long
'Read data into an array
With Sheet1
data = .Range(.Range("A1"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
'Create lists of unique lastnames containing the firstnames
Set lastList = New Collection
For r = 2 To UBound(data, 1)
firstText = CStr(data(r, 1))
lastText = CStr(data(r, 2))
Set firstList = Nothing
On Error Resume Next
Set firstList = lastList(lastText)
On Error GoTo 0
If firstList Is Nothing Then
Set firstList = New Collection
lastList.Add firstList, lastText
End If
firstList.Add firstText
Next
'Write results to sheet
ReDim output(1 To UBound(data, 1) - 1, 1 To 3)
For r = 2 To UBound(data, 1)
lastText = CStr(data(r, 2))
Set firstList = lastList(lastText)
'Calculate the distribution
dist(3) = firstList.Count / 3 'thanks #Comitern
dist(2) = dist(3)
dist(1) = firstList.Count - dist(2) - dist(3)
i = 1: c = 1: str = ""
For Each first In firstList
str = str & IIf(i > 1, ", ", "") & first
i = i + 1
If i > dist(c) Then
output(r - 1, c) = str
i = 1: c = c + 1: str = ""
End If
Next
Next
Sheet1.Range("C2").Resize(UBound(output, 1), UBound(output, 2)).Value = output
the code below works 100%. It scans for a match in Column B and copies and renames a group of cells when a match is found. However the is a line For lRow = Sheets("HR-Calc").Cells(Cells.Rows.count, "b").End(xlUp).Row To 7 Step -1
Where the step -1 will scan row by row from the bottom of the sheet until a match is found. It would be much easier if the step was set to End.(xlUp) instead of -1. searching every row is overkill because of how the data is set up End.(xlUp) would massive cut down the run time.
Is something like this possible?
Sub Fill_CB_Calc()
M_Start:
Application.ScreenUpdating = True
Sheets("summary").Activate
d_input = Application.InputBox("select first cell in data column", "Column Data Check", Default:="", Type:=8).Address(ReferenceStyle:=xlA1, RowAbsolute:=True, ColumnAbsolute:=False)
data_col = Left(d_input, InStr(2, d_input, "$") - 1)
data_row = Right(d_input, Len(d_input) - InStr(2, d_input, "$"))
Application.ScreenUpdating = False
Sheets("summary").Activate
Range(d_input).End(xlDown).Select
data_last = ActiveCell.Row
If IsEmpty(Range(data_col & data_row + 1)) = True Then
data_last = data_row
Else
End If
For j = data_row To data_last
CBtype = Sheets("summary").Range(data_col & j)
Sheets("HR-Calc").Activate
For lRow = Sheets("HR-Calc").Cells(Cells.Rows.count, "b").End(xlUp).Row To 7 Step -1
If Sheets("HR-Calc").Cells(lRow, "b") = CBtype Then
CBend = Sheets("HR-Calc").Range("C" & lRow).End(xlDown).Row + 1
Sheets("HR-Calc").Rows(lRow & ":" & CBend).Copy
CBstart = Sheets("HR-Calc").Range("c50000").End(xlUp).Row + 2
ActiveWindow.ScrollRow = CBstart - 8
Sheets("HR-Calc").Range("A" & CBstart).Insert Shift:=xlDown
CBold = Right(Range("c" & CBstart), Len(Range("C" & CBstart)) - 2)
box_name = Sheets("summary").Range(data_col & j).Offset(0, -10)
CBnew = Right(box_name, Len(box_name) - 2) & "-" ' <--this is custom and can be changed based on CB naming structure
If CBnew = "" Or vbCancel Then
End If
CBend2 = Range("c50000").End(xlUp).Row - 2
Range("C" & CBstart + 1 & ":" & "C" & CBend2).Select
Selection.Replace What:=CBold & "-", Replacement:=CBnew, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("C" & CBstart).FormulaR1C1 = "CB" & Left(CBnew, Len(CBnew) - 1)
GoTo M_Start2
Else
End If
Next lRow
M_Start2:
Next j
YN_result = MsgBox("Fill info for another block/inverter?", vbYesNo + vbExclamation)
If YN_result = vbYes Then GoTo M_Start
If YN_result = vbNo Then GoTo jumpout
jumpout:
' Sheets("summary").Range(d_input).Select
Application.ScreenUpdating = True
End Sub
I'm not sure if this will help but I've had a great performance increase with pulling the entire range you need to loop through into a variant array and then looping through the array. If I need to loop through large data sets, this method has worked out well.
Dim varArray as Variant
varArray = Range(....) 'set varArray to the range you're looping through
For y = 1 to uBound(varArray,1) 'loops through rows of the array
'code for each row here
'to loop through individual columns in that row, throw in another loop
For x = 1 to uBound(varArray, 2) 'loop through columns of array
'code here
Next x
Next y
You can also define the column indexes prior to executing the loop. Then you only need to execute the you need to pull those directly in the loop.
'prior to executing the loop, define the column index of what you need to look at
Dim colRevenue as Integer
colRevenue = 5 'or a find function that searches for a header named "Revenue"
Dim varArray as Variant
varArray = Range(....) 'set varArray to the range you're looping through
For y = 1 to uBound(varArray,1) 'loops through rows of the array
tmpRevenue = CDbl(varArray(y, colRevenue))
Next y
Hope this helps.
Look at doing a .find from the bottom up.
Perform a FIND, within vba, from the bottom of a range up
That will eliminate the need to do the for loop from the last row to the first occurrence of the value you want to locate.