I have 2 columns of data (with headers) where A (sequential) always has duplicates (sometimes 2-3), however B data (also sequential) is always unique and dupes are non-existant. I found this solution from #Jeeped and modified to fit needs - obviously doesn't work since I don't know how to define max(B) within code.
Sub RemoDupeMaxB()
Dim wb1 As Workbook
Dim lr As Long, i As Long
Set wb1 = Workbooks(“Survey Beta.xlsm")
With wb1.Sheets("VERT SCALES")
lr = Application.Max(.Cells(Rows.Count, 1).End(xlUp).Row, _
.Cells(Rows.Count, 2).End(xlUp).Row)
For i = lr To 1 Step -1
If .Cells(i, 1).Value > '??? And _
(.Cells(i, 2).Value > Max(B:B)) Then
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
What I want vba to do is to use the criteria of max(B) to delete (rows) all other dupes from A - that is keep the max(B) row data.
I think I would approach this problem with a double-for loop, like so
Sub RemoDupeMaxB()
Dim wb1 As Workbook
Dim lr As Long, i As Long
Set wb1 = Workbooks(“Survey Beta.xlsm")
With wb1.Sheets("VERT SCALES")
lr = Application.Max(.Cells(Rows.Count, 1).End(xlUp).Row, _
.Cells(Rows.Count, 2).End(xlUp).Row)
For i = lr To 1 Step -1
for j = i - 1 to 1 Step -1
If .Cells(i, 1).Value = .Cells(j, 1).Value And _
.Cells(i, 2).Value > .Cells(j, 2).Value Then
.Rows(j).EntireRow.Delete
End If
Next j
Next i
End With
End Sub
Related
I need a loop that will match and select different columns (not in sequential order) and paste them to another sheet all whilst keeping the condition in check. It would also be ideal if when the values get pasted that the formatting for the cell is not carried over, just the value.
Below is the code I am currently using:
Sub Test()
Application.ScreenUpdating = False
Sheets("DATA").Select
lr = Range("B" & Rows.Count).End(xlUp).Row
Range("P3").Select
For i = 3 To lr
If Cells(i, 2) <> "" Then Range(Cells(i, 7), Cells(i, 16), Cells(i, 26)).Copy
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Next
Application.ScreenUpdating = True
End Sub
The problem is declaring the columns I want the loop to paste. I need the loop to run through the 16th column, check empty values, and then paste the index/matched value in the rows of columns 7,16,and 26 (so not in sequential order).. Any help would be appreciated.
The next code has to do what I understood you need. Please check it and confirm this aspect. It is very fast, working only in memory...
Sub PastingNextPage()
Dim sh As Worksheet, sh1 As Worksheet, arrIn As Variant, arrOut() As Variant
Dim lastRowIn As Long, lastRowOut As Long, nonEmpt As Long, rngP As Range, nrEl As Long
Dim i As Long, j As Long, P As Long
Set sh = Sheets("DATA"): lastRowIn = sh.Range("P" & sh.Rows.count).End(xlUp).Row
Set sh1 = Sheets("Sheet2"): lastRowOut = sh1.Range("A" & sh1.Rows.count).End(xlUp).Row + 1
arrIn = sh.Range("G2:Z" & lastRowIn).Value
nrEl = lastRowIn - Application.WorksheetFunction.CountIf(sh.Range("P2:P" & lastRowIn), "") - 2
P = 10 'column P:P number in the range starting with G:G column
ReDim arrOut(nrEl, 3) 'redim the array to keep the collected values
For i = 1 To lastRowIn - 1
If arrIn(i, P) <> "" Then
arrOut(j, 0) = arrIn(i, 1): arrOut(j, 1) = arrIn(i, P): arrOut(j, 2) = arrIn(i, 20)
j = j + 1
End If
Next i
sh1.Range(sh1.Cells(lastRowOut, "A"), sh1.Cells(lastRowOut + nrEl, "C")).Value = arrOut
End Sub
It does not select anything, you can run it activating any of the two involved sheets. I would recommend to be in "Sheet2" and see the result. If you want to repeat the test, its result will be added after the previous testing resulted rows...
If something unclear or not doing what you need, do not hesitate to ask for clarifications.
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
I have the below code that pulls out specific data from the spreadsheet and formats it into a table. Both for loops work, however the first one will only work if I'm on Sheet1 and the second one will only work if I'm on Sheet2.
I can't work out how to rewrite it to make both sections of code work anywhere in the spreadsheet. Preferably from Sheet1 if it had to be.
Sub MakeMyTable()
Dim Col As Variant
Dim Col2 As Variant
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "D"
Col2 = "A"
StartRow = 1
X = 3
'This with pulls the formatted data into totals into Sheet2
With Sheets("Sheet1")
LastRow2 = Cells(Rows.Count, Col).End(xlUp).Row
For R = StartRow + 1 To LastRow2 + 1 Step 1
If .Cells(R, Col) = "" Then
Sheets("Sheet2").Cells(1, "A").Value = "Project Cost Centers Costs At " & Date
Sheets("Sheet2").Cells(X, "A").Value = .Cells(R - 1, Col).Value
Sheets("Sheet2").Cells(X, "B").Value = .Cells(R - 1, "F").Value
Sheets("Sheet2").Cells(X, "C").Value = .Cells(R, "P").Value
Sheets("Sheet2").Cells(X, "C").NumberFormat = "$#,##0.00"
X = X + 1
End If
Next R
End With
' This with finds any cell that has "RX04F.029.038" in it and moves it to the
' bottom of the table.
With Sheets("Sheet2")
LastRow2 = Cells(Rows.Count, Col2).End(xlUp).Row
For R = LastRow2 To StartRow + 2 Step -1
If InStr(1, Cells(R, Col2).Value, "RX04F.029.038") > 0 Then
Rows(R).Cut
Rows(LastRow2 + 1).Insert Shift:=xlDown
R = R + 1
LastRow2 = LastRow2 - 1
End If
Next R
End With
End Sub
You also need to properly link your With statement to the ranges you use. For example, you have With Sheets("Sheet2") but them don't link the lastRow2 = Cells().Row to it. Do this for all such instances: LastRow2 = .Cells(.Rows.Count,Col2).End(xlUp).Row. Otherwise, any use of a range will occur on the ActiveSheet, whatever that may be. – BruceWayne 3 mins ago
Edit: BruceWayne gave me the answer I need in the comments but cant mark it as an answer so this is the best I could do. Thank you
You can change the sheet names to what you want.
Or you can swap:
With Sheets("Sheet1")
for
With ActiveSheet
if you want to run the loops on the active sheet.
I am new to VBA excel, a week old. I have little knowledge in C , with that I have created a program.
The task is that "to search a particluar Number in one excel worksheet(1) and compare in another worksheet(2), get the corrosponding coloumn data , concatinate the information into once cell on Worksheet(1) .
I tried but I can't get the process done I need a valuable suggestion how to fix my code.
My code:
Sub test1()
Dim iComp
Worksheets("BSM_STF_iO").Select
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
a = onlyDigits(Range("A" & i).Value)
If InStr(a, "T") Then
Else
Worksheets("Tabelle1").Select
destlastrow = Range("B" & Rows.Count).End(xlUp).Row
For j = 2 To destlastrow
b = onlyDigits(Range("B" & j).Value)
iComp = StrComp(a, b, vbBinaryCompare)
Select Case iComp
Case 0
Sheets("Tabelle1").Range(Sheets("Tabelle1").Cells(j, 3), Sheets("Tabelle1").Cells(j, 4)).Copy
Sheets("Tabelle1").Activate
erow = Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Sheets("Tabelle1").Range(Cells(erow, 8), Cells(erow, 9))
Sheets("BSM_STF_iO").Activate
End Select
Next j
End If
Next i
End Sub
Function onlyDigits(s As String) As String
Dim retval As String
Dim i As Integer
retval = ""
retval = s
onlyDigits = retval
End Function
Example:
I need to put all the information from "tabelle1" worksheet information of "10000" to "BSM_STF_io" 10000.
BSM_STF_io
Tabellle1
See if this helps (I removed the .Activate/.Select parts):
Sub test1()
Dim iComp
Dim bsmWS As Worksheet, tabWS As Worksheet
Set bsmWS = Sheets("BSM_STF_iO")
Set tabWS = Sheets("Tabelle1")
LastRow = bsmWS.Range("A" & bsmWS.Rows.Count).End(xlUp).Row
For i = 2 To LastRow
a = onlyDigits(bsmWS.Range("A" & i).Value)
If InStr(a, "T") Then
' do something?
Else
destlastrow = tabWS.Range("B" & tabWS.Rows.Count).End(xlUp).Row
For j = 2 To destlastrow
b = onlyDigits(tabWS.Range("B" & j).Value)
iComp = StrComp(a, b, vbBinaryCompare)
Select Case iComp
Case 0
With tabWS
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Range(.Cells(j, 3), .Cells(j, 4)).Copy .Range(.Cells(erow, 8), .Cells(erow, 9))
End With 'tabWS
End Select
Next j
End If
Next i
End Sub
In your original code, sometimes you correctly gave the sheets for the range, but other times not (you should use Sheets("whatever").Rows.Count too). This will hopefully tighten it up and work for you.
I want to copy data from one sheet to another with few conditions:
1. Start with row 1 and column 1 and match if the R1 C2 is not empty then copy the pair R1 C1 and R1 C2 and paste into the other sheet as a new row.
increment the counter for column and match R1 C1 with R1 C3 and so on.
increment the Row when the column counter reaches 10.
I tried the below code but gives compile error as Sub or function not defined.
Please help.
Private Sub CommandButton1_Click()
Dim x As Integer
Dim y As Integer
x = 2
y = 2
Do While Cells(x, 1) <> ""
If Cells(x, y) <> "" Then
Worksheets("Sheet1").Cells(x, 2).Copy
Worksheets("Sheet2").Activate
erow = Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(erow)
End If
Worksheets("Sheet1").Activate
y = y + 1
If y = 10 Then x = x + 1
End If
Loop
End Sub
You are geting that error because of > in Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
Avoid the use of using Integer when you are working with rows. Post excel2007, the row count has increased and the Integer may not be able to handle the row number.
Avoid the use of .Activate.
Is this what you are trying? (Untested)
Note: I am demonstrating and hence I am working with the excel cells directly. But in reality, I would be using autofilter & arrays to perform this operation.
Private Sub CommandButton1_Click()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim lRowInput As Long, lRowOutput As Long
Dim i As Long, j As Long
Set wsInput = ThisWorkbook.Worksheets("Sheet1")
Set wsOutput = ThisWorkbook.Worksheets("Sheet2")
With wsInput
lRowInput = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRowInput
If .Cells(i, 2).Value <> "" Then
For j = 3 To 10
lRowOutput = wsOutput.Range("A" & wsOutput.Rows.Count).End(xlUp).Row + 1
.Range(.Range(.Cells(i, 1), .Cells(i, 1)).Address & _
"," & _
.Range(.Cells(i, j), .Cells(i, j)).Address).Copy _
wsOutput.Range("A" & lRowOutput)
Next j
End If
Next i
End With
End Sub