Looping and finding similar number in VBA - vba

I am very new to VBA. Just started reading it up 2 days ago. I am wondering how could I write a VB codes assigned to a button to read through the whole column and search for similar numbers.
After that identifying similar numbers, it would need to move on to another column to check if the character in the column are same too.
If both of the logic = true . How can i change the cell of the value of another column?
Sample data
For the current example. The code should know that the first column had matching numbers. After that it will check for the name which is "a" in the example. After that it will automatically change the point to 1 and 0. If there are 3 same ones it will be 1,0,0 for the point

You may try recording whatever you want to do with record macros first, then filter out the codes that are not necessary. If you do not know how to record it using macros, click on the link below. You can learn from the recorded macros and slowly improvise your codes in the future from the experience you may gain.
Here's [a link] (http://www.dummies.com/software/microsoft-office/excel/how-to-record-a-macro-in-excel-2016/)

As per image attached in image I am assuming numbers are in Column A, column to check characters is Column J and result needs to be displayed in Column O then try following code.
Sub Demo()
Dim dict1 As Object
Dim ws As Worksheet
Dim cel As Range, fCell As Range
Dim lastRow As Long, temp As Long
Dim c1
Set dict1 = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet2 to your data sheet
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in Column A
c1 = .Range("A2:A" & lastRow)
For i = UBound(c1, 1) To 1 Step -1 'enter unique values with corresponding values in dict1
dict1(c1(i, 1)) = .Range("J" & i + 1) '+1 for Row 2
Next i
Set fCell = .Range("A2")
For Each cel In .Range("A2:A" & lastRow) 'loop through each cell in Column A
temp = WorksheetFunction.CountIf(.Range(fCell, cel.Address), cel) 'get count
If temp > 1 Then
If cel.Offset(0, 9) = dict1(cel.Value) Then
cel.Offset(0, 14).Value = 0
Else
cel.Offset(0, 14).Value = 1
End If
Else
cel.Offset(0, 14).Value = 1
End If
Next cel
End With
End Sub
EDIT
Sub Demo()
Dim ws As Worksheet
Dim lastRow As Long
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.count, "A").End(xlUp).Row 'last row with data in Column A
.Range("O2").Formula = "=IF(MOD(SUMPRODUCT(($A$2:$A2=A2)*($J$2:$J2=J2)),3)=1,1,0)" 'enter formula in Cell O2
.Range("O2").AutoFill Destination:=.Range("O2:O" & lastRow) 'drag formula down
.Range("O2:O" & lastRow).Value = .Range("O2:O" & lastRow).Value 'keep only values
End With
Application.ScreenUpdating = True
End Sub

Related

VBA code to add days from one column to another

I'm having the following columns in Excel: Document Date (all cells have values) & Initial Disposition Date (there're blanks within the column).
Each Document Date cell corresponds to an Initial Disposition Date cell.
For any blank Initial Disposition Date cells, I'd like to set them to be 7 days from the corresponding Document Date. (Strictly blank cells)
Ex: Document Date = 10/01/2018. Desired Initial Disposition Date = 10/08/2018.
Is there a code to execute such action? (I have approximately 55,000 rows and 51 columns by the way).
Thank you very much! Any suggestions or ideas are highly appreciated!
Looping through a range is a little quicker in this case. I am assuming your data is on Sheet1, your Document Date is on Column A and your Initial Deposition is on Column B.
Last, you need to determine if you want that 7 days to be inclusive of weekends or not. I left you a solution for both. You will need to remove one of the action statements (in middle of loop)
Option Explicit
Sub BetterCallSaul()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LRow As Long, iRange As Range, iCell As Range
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set iRange = ws.Range("B2:B" & LRow)
Application.ScreenUpdating = False
For Each iCell In iRange
If iCell = "" Then
iCell = iCell.Offset(, -1) + 7 'Includes Weekends
iCell = WorksheetFunction.WorkDay(iCell.Offset(, -1), 7) 'Excludes Weekends
End If
Next iCell
Application.ScreenUpdating = True
End Sub
If your Document Date is on Column A and you Initial Disposition Date in Column B, then the following would achieve your desired results:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
Lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For i = 2 To Lastrow
'loop from row 2 to the last row with data
If ws.Cells(i, "B").Value = "" Then
'if there is no value in Column B then
ws.Cells(i, "B").Value = ws.Cells(i, "A").Value + 7
'add seven days to the date from Column A
End If
Next i
End Sub
A formula on all blanks would avoid the delays looping through the worksheet column(s).
Sub ddPlus7()
Dim dd As Long, didd As Long
With Worksheets("sheet1")
'no error control on the next two lines so those header labels better be there
dd = Application.Match("Document Date", .Rows(1), 0)
didd = Application.Match("Desired Initial Disposition Date", .Rows(1), 0)
On Error Resume Next
With Intersect(.Columns(dd).SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow, _
.Columns(didd).SpecialCells(xlCellTypeBlanks).EntireRow, _
.Columns(didd))
.FormulaR1C1 = "=rc[" & dd - didd & "]+7"
End With
On Error GoTo 0
End With
End Sub

Excel VBA - Shift data across multiple columns to a single column

I have a macro right now that pulls data from a different sheet into a new sheet, then formats the data into a form I can use. The issue I have is that some of the PNs that I pull from the other sheet are in different cells for ease of viewing. (For example, the top level PN is in cell C2 and any parts that are a part of the part in C2 may be listed in D3, to show it's a sub-part).
I need code that will shift all PNs across varying columns into a single column. Once all PNs are moved, the other columns should be deleted (D through F). The data ranges from column C to F. Depending on the table the macro pulls data from, the length of the data varies. The macro will need to be able to handle this.
Here's an example of what my sheet looks like after my macro runs:
I'm trying to check column C for empty rows. If say C3 is empty, I then want to check D3 for text. If there is text, I want text in D3 to move to C3. If there is no text, check E3. Same process repeated. From what I've found online, I have this code so far (however, it doesn't run properly in my macro)...
'Copy PNs that are out of line and paste them in the correct column
Dim N As Long, i As Long, j As Long
Set ws1 = Worksheets("KDLSA")
N = ws1.Cells(Rows.Count, "C").End(xlUp).Row
j = 4
For Each cell In Range("D2:F" & ws1.Cells(Rows.Count, "F").End(xlUp).Row)
If cell.Value = "" Then 'if cell C is blank, I want to shift the text to fill column C
ws1.Range("C" & j).Value = ws1.Range("D" & cell.Row).Value 'copy PN in column E to column D - this needs to be more robust to cover my range of columns rather than just D and E
j = j + 1
End If
Next cell
Any help is appreciated.
Change your "For" block to:
With ws1.UsedRange
lastRow = .Rows(.Rows.Count).Row
End With
For Each cell In Range("C2:C" & lastRow)
If cell.Value = "" Then
thisRow = cell.Row
For Each horCell In Range(Cells(thisRow, "D"), Cells(thisRow, "F"))
If Not horCell.Value = "" Then
cell.Value = horCell.Value
Exit For
End If
Next horCell
End If
Next cell
Range("D:F").EntireColumn.Delete
By cycling only through column C, you can loop through D-F only if C is blank, and when you find the one with data, it puts it in C.
If you also need dynamic range on the number of columns, then do:
With ws1.UsedRange
lastRow = .Rows(.Rows.Count).Row
lastColumn = .Columns(.Columns.Count).Column
End With
For Each cell In Range("C2:C" & lastRow)
If cell.Value = "" Then
thisRow = cell.Row
For Each horCell In Range(Cells(thisRow, "D"), Cells(thisRow, lastColumn))
If Not horCell.Value = "" Then
cell.Value = horCell.Value
Exit For
End If
Next horCell
End If
Next cell
Range(Cells(2, "D"), Cells(2, lastColumn)).EntireColumn.Delete
Or with a correct lastRow in your for loop "to" range, change your code to
If Not cell = "" then
ws1.range ("C" & cell.Row).Value = cell.Value
End if
You are looping through columns D-F, so "cell" is a cell in that range, not in column C. You therefore want to test for the ones that are NOT empty and then put their values in the corresponding cell in column C. :-)
As Tehscript mentioned you dont need a macro. If you nevertheless want to use a macro (maybe your real case is more complex than the example) here is a starting point for you.
The example below will shift the cells only once. So you might want to execute the loop several times. (You could also loop over the rowIndex and use a while loop for each row.)
The code could be further refactored but I hope this way it is easy to read.
Sub ShiftCells()
Dim myWorkSheet As Worksheet
Set myWorkSheet = Worksheets("Tabelle1")
Dim maxRowIndex As Long
maxRowIndex = GetMaxRowIndex(myWorkSheet)
Dim rowIndex As Long
Dim columnIndex As Long
Dim leftCell As Range
Dim rightCell As Range
For Each Cell In Range("C2:F" & maxRowIndex)
If Cell.Value = "" Then
shiftedCell = True
rowIndex = Cell.Row
columnIndex = Cell.Column
Set leftCell = myWorkSheet.Cells(rowIndex, columnIndex)
Set rightCell = myWorkSheet.Cells(rowIndex, columnIndex + 1)
leftCell.Value = rightCell.Value
rightCell.Value = ""
End If
Next Cell
End Sub
Function GetMaxRowIndex(ByVal myWorkSheet As Worksheet) As Long
Dim numberofRowsInColumnC As Long
numberofRowsInColumnC = myWorkSheet.Cells(Rows.Count, "C").End(xlUp).Row
Dim numberofRowsInColumnD As Long
numberofRowsInColumnD = myWorkSheet.Cells(Rows.Count, "D").End(xlUp).Row
Dim numberofRowsInColumnE As Long
numberofRowsInColumnE = myWorkSheet.Cells(Rows.Count, "E").End(xlUp).Row
Dim numberofRowsInColumnF As Long
numberofRowsInColumnF = myWorkSheet.Cells(Rows.Count, "F").End(xlUp).Row
Dim maxNumberOfRows As Long
maxNumberOfRows = WorksheetFunction.Max(numberofRowsInColumnC, _
numberofRowsInColumnD, _
numberofRowsInColumnE, _
numberofRowsInColumnF _
)
GetMaxRowIndex = maxNumberOfRows
End Function

Excel VBA Copy content from every nth cell and paste into every nth cell

Dear StackOverflow community,
I am making my finances via Excel just to keep track over my financial status. I am using the raw data from my banking site and had a macro to sort the data more less and have it ready for copy pasting. But the macro I created didn't really satisfy me and I am kind of thinking about how to do the following thing in Visual Basic for Application:
I want to:
select every 3rd cell from a sheet (in my case B3) (done)
Dim rRange As Range
Dim rEveryNth As Range
Dim lRow As Long
With Tabelle5
Set rRange = .Range("B3", .Cells(.Rows.Count, "B").End(xlUp))
End With
For lRow = 1 To rRange.Rows.Count Step 3
If lRow = 1 Then
Set rEveryNth = rRange(lRow, 1)
Else
Set rEveryNth = Union(rRange(lRow, 1), rEveryNth)
End If
Next lRow
Application.Goto rEveryNth
put a space after these cells (like literally pressing space bar after every single cell) (done)
Dim c As Range
For Each c In Selection
If c.Value <> "" Then c.Value = c.Value & " "
Next
select every 3rd cell from the same sheet but from another offset (B4) (done)
With Tabelle5
Set rRange = .Range("B4", .Cells(.Rows.Count, "B").End(xlUp))
End With
For lRow = 1 To rRange.Rows.Count Step 3
If lRow = 1 Then
Set rEveryNth = rRange(lRow, 1)
Else
Set rEveryNth = Union(rRange(lRow, 1), rEveryNth)
End If
Next lRow
Application.Goto rEveryNth
copy the text of these cells and then paste them into every 3rd cell starting from B3 WITHOUT erasing the original text from the cells (HELP NEEDED HERE)
delete every 3rd row starting from B4 (also help needed)
delete every 2nd row starting from B2 (same as above
have it copy-ready (just usual copy command, also done)
So as you see I need a trick to somehow copy the single cells and paste them into the cell above it without overwriting it (so text from B4 gets copied and pasted into B3, same from B7 to B6 etc.)
I tried to do it with the following command:
With Tabelle5
Set rRange = .Range("B3", .Cells(.Rows.Count, "B").End(xlUp))
End With
For lRow = 1 To rRange.Rows.Count Step 3
If lRow = 1 Then
Set rEveryNth = rRange(lRow, 1)
Else
Set rEveryNth = Union(rRange(lRow, 1), rEveryNth)
End If
Next lRow
Application.Goto rEveryNth
For Each c In Selection
If c.Value <> "" Then c.Value = c.Value & rEveryNth
Next
Only problem is that it only pastes the text from the last cell I have and pastes the text into all the other cells, which is not what I want.
Is there any repeat command to select one cell, copy the text, paste it to the cell above without overwriting it? If yes, how do I do it? (I have to do it 20 times in total to have the text copied and pasted correctly)
And for the 2nd part: Any help about selecting every 2nd/3rd row instead of every 2nd/3rd cell in the column?
What I treid so far (thank you for the suggestions) is following:
Dim rRange As Range
Dim rEveryNth As Range
Dim lRow As Long
With Tabelle5
Set rRange = .Range("B4", .Cells(.Rows.Count, "B").End(xlUp))
End With
For lRow = 1 To rRange.Rows.Count Step 3
If lRow = 1 Then
Set rEveryNth = rRange(lRow, 1)
Else
Set rEveryNth = Union(rRange(lRow, 1), rEveryNth)
End If
Next lRow
Application.Goto rEveryNth
Range(rEveryNth.Address).Offset(-1, 0).Value = rEveryNth.Value
End Sub
But it still copies the last cell and pastes it into every other one...
I think this is what you mean:
Dim rRange As Range, c As Range, lRow As Long
With Tabelle5
Set rRange = .Range("B3", .Cells(.Rows.Count, "B").End(xlUp))
End With
For lRow = 1 To rRange.Rows.Count Step 3
Set c = rRange.Cells(lRow)
c.Value = c.Value & " " & c.Offset(1,0).Value
Next lRow
You're over-complicating your code by building up those union'ed ranges...
To copy data from a cell and paste it into the cell above, you can try something like this:
currentRange.offset(-1,0).value = currentRange.value
This sets the value of the cell above currentRange to the value of currentRange and doesn't touch the value in currentRange.
For example,
set rng = range("B7")
range(rng.address).offset(-1,0).value = rng.value
will set the value in B6 to the value in B7. look up the offset function for more info on it
Option Explicit
Sub test()
Dim ws As Worksheet
Dim i As Integer
Dim copyvalue As String
Dim copyvalue2 As String
i = 1
For Each ws In ThisWorkbook.Worksheets
ActiveWorkbook.Worksheets(i).Select
copyvalue = Range("B3").Value
copyvalue2 = Range("B4").Value
Range("B3") = copyvalue & " " & copyvalue2
Range("B5").Select
Selection.EntireRow.Delete
Range("B6").Select
Selection.EntireRow.Delete
i = i + 1
Next ws
End Sub
This will cycle through each worksheet and combine B3 a space and B4 then delete rows 5 and 7. Does this help?

Row Number reference with VBA

I have searched a bit for a VBA code that will list me a row reference and am not finding results. Perhaps I am missing what the actual term for it is?
I have a list of names in Column A, starting at A2. Then what I would like is a listing of 1,2,3,4,5 going down Column B, starting from B2, until the names stop.
I can do this as a formula but need to have the values set there by a macro in this case.
Can this be done?
If I understand you correctly then this should work:
Sub test()
Dim lastRow As Long, counter As Long
Dim cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("NAME_OF_YOUR_WORKSHEET")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
counter = 1
For Each cell In ws.Range("B2:B" & lastRow)
cell.Value = counter
counter = counter + 1
Next cell
End Sub
No need for a loop:
Sub NumberRows()
With Sheets("Sheet Name Here")
With .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
.Formula = "=ROW()-1"
.Value = .Value
End With
End With
End Sub

Copy/Paste multiple rows in VBA

I am attempting to do a simple copy row, paste row within a workbook. I've searched threads and tried changing my code multiple times to no avail.
The one that comes closest to working is this but it only copies a single instance of matching criteria.
I am trying to create a loop that will copy all of the rows that has a match in one of the columns.
So, if 8 columns, each row with matching value in column 7 should copy to a named sheet.
Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long
For Each cell In MR
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
I like this because I need to target multiple destination sheets with different criteria but I need all rows that match criteria to copy over.
EDITED CODE IN RESPONSE TO NEW REQUEST:
The code below will copy all of the rows in Sheet Main and paste them into the corresponding worksheets based on the value in Column 7.
Do note: If there is a value in Column 7 that does NOT match to an existing sheet name, the code will throw an error. Modify the code to handle that exception.
Let me know of any additional needed help.
Sub CopyStuff()
Dim wsMain As Worksheet
Dim wsPaste As Worksheet
Dim rngCopy As Range
Dim nLastRow As Long
Dim nPasteRow As Long
Dim rngCell As Range
Dim ws As Worksheet
Const COLUMN_TO_LOOP As Integer = 7
Application.ScreenUpdating = False
Set wsMain = Worksheets("Main")
nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
Set rngCopy = wsMain.Range("A2:H" & nLastRow)
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) = "MAIN" Then
'Do Nothing for now
Else
Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
End If
Next ws
For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
On Error Resume Next
Set wsPaste = Worksheets(rngCell.Value)
On Error GoTo 0
If wsPaste Is Nothing Then
MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
Else
nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
End If
Set wsPaste = Nothing
Next rngCell
Application.ScreenUpdating = True
End Sub
Your current code is pasting to the same row in each sheet over and over, to the last row with a value in column A. Range("A" & Rows.Count).End(xlUp) says, roughly "go to the very bottom of the spreadsheet in column A, and then jump up from there to the next lowest cell in column A with contents," which gets you back to the same cell each time.
Instead, you could use lines of the pattern:
Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial
Where UsedRange is a range containing all of the cells on the sheet with data in them. The + 1 puts you on the following row.
You could make this a little prettier using With:
With Sheets("X")
.Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial
End With