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.
Related
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'm trying to create a macro that compares 2 columns, each one from a different file, and gets every match into a third file together with some additional cells from one of the files.
Also, in the first 2 files have some editing on them so their cells with actual data start on the 4th and 2nd row of their respective columns so i used 2 different variable so my loops would start at these cells.
The thing is, even if my macro runs without errors it doesn't copy the data to the third file.
I have the following code:
Sub Compare()
Dim w1 As Worksheet, w2 As Worksheet, w3 As Worksheet
Dim range1 As Range, range2 As Range
Set w1 = Workbooks("Worksheet_Name1").Worksheets("Sheet1")
Set w2 = Workbooks("Worksheet_Name2").Worksheets("Sheet2")
Set w3 = Workbooks("Worksheet_Name3").Worksheets("Sheet3")
Set range1 = w1.Range("E4", w1.Range("E" & Rows.Count).End(xlUp))
Set range2 = w2.Range("A2", w2.Range("A" & Rows.Count).End(xlUp))
For Each c In range2
rangeVar2 = c
If rangeVar2 > 3 Then
For Each n In range1
rangeVar1 = n
If rangeVar > 2 Then
If w1.Cells(n, "E").Value = w2.Cells(c, "A").Value Then
w3.Cells(c, "A").Value = w1.Cells(c, "E").Value
w3.Cells(c, "B").Value = w2.Cells(c, "A").Value
End If
End If
Next n
End If
Next c
End Sub
Okay, I re-wrote this for you and changed a few things. This could still be modified a bit but this should at least work for now.
The rangeVar1 and rangeVar2 were completely redundant, also preventing your code from running (I think). No need for those.
Sub ReWrite()
Dim w1 As Worksheet, w2 As Worksheet, w3 As Worksheet
Set w1 = Workbooks("Worksheet_Name1").Worksheets("Sheet1")
Set w2 = Workbooks("Worksheet_Name2").Worksheets("Sheet2")
Set w3 = Workbooks("Worksheet_Name3").Worksheets("Sheet3")
Dim lastrow1 As Long, lastrow2 As Long, i As Long, j As Long
lastrow1 = w1.Cells(w1.Rows.Count, "E").End(xlUp).Row
lastrow2 = w2.Cells(w2.Rows.Count, "A").End(xlUp).Row
For i = 4 To lastrow1
For j = 2 To lastrow2
If w1.Range("E" & i).Value = w2.Range("A" & j).Value Then
w3.Range("A" & j).Value = w1.Range("E" & i).Value
w3.Range("B" & j).Value = w2.Range("A" & j).Value
End If
Next j
Next i
End Sub
The pic shows what happens with my code.
I have a user form and I add the labels of the user form into the selected worksheet. And this is what I tried. Now the problem is why is it that there is one cell not on the same row as the others?
Dim c As Control
For Each c In Me.Controls
If TypeName(c) = "Label" Then
With ActiveSheet
i = i + 1
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If c <> "Chapter" Then
.Range(Cells(1, 1), Cells(1, i)).Name = "Chapter1"
.Range("Chapter1").Merge
.Range("Chapter1").Value = "Chapter 1"
.Range("Chapter1").HorizontalAlignment = xlCenter
.Cells(lastRow, i).Value = c.Caption
End If
End With
End If
Next
The problem is that the first time you do .Cells(.Rows.Count, 1).End(xlUp).Row there will not be anything yet in A2, so lastRow will be 1. But once you put the value "No." in that cell the next time you execute that code (with i being 2), A2 will be filled, so now .Cells(.Rows.Count, 1).End(xlUp).Row will return 2, giving you the effect you get: all other values end up one row lower.
There are several way to solve this, but here is one way. Add + IIf(i = 1, 1, 0) the assignment of lastRow:
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + IIf(i = 1, 1, 0)
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
I really need some help.
Problem: I have a workbook with 2 worksheets. Both sheets has headers. Sheet1 is a list of account numbers in column A and the same for sheet 2 column A. Now, what I need to do is this:
if I place a date in column AI in sheet 2 for a specific account number, then find the corresponding account number in sheet 1 and place the word "Complete" in column Y for that account.
I hope I explained this enough. Below is what I came up with so far, but got stuck:
Sub UpdateTBP()
Dim i
Dim j
Dim k
Dim LastRow
Dim LastRow2
LastRow = Sheets("Portfolio").Cells(Rows.Count, 1).End(xlUp).Row
LastRow2 = Sheets("TBP").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To (LastRow - 1)
For j = 2 To (LastRow2 - 1)
If Sheets("Portfolio").Cells(i, 1) = Sheets("TBP").Cells(j, 1).value Then
For k = 35 To 35
If Sheets("TBP").Cells(j, 35) <> "" Then
Sheets("Portfolio").Cells(i, Y).value = "Complete"
End If
Next
End If
Next
Next
ThisWorkbook.Save
End Sub
I was able to make it work by using the following modified code:
Sub UpdateTBP()
Dim i
Dim j
Dim k
Dim LastRow
Dim LastRow2
LastRow = Sheets("Portfolio").Cells(Rows.Count, 1).End(xlUp).Row
LastRow2 = Sheets("TBP").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To (LastRow - 1)
For j = 2 To (LastRow2 - 1)
If Sheets("Portfolio").Cells(i, 1).Value = Sheets("TBP").Cells(j, 1).Value Then
If Sheets("TBP").Cells(j, 35) <> "" Then
Sheets("Portfolio").Cells(i, 25).Value = "Complete"
End If
End If
Next
Next
ThisWorkbook.Save
End Sub
Please note that this will not include your last row of data as you have subtracted it out with:
For i = 2 To (LastRow - 1)
For j = 2 To (LastRow2 - 1)
If you wish to include that last row, just use the following:
For i = 2 to LastRow
For j = 2 to LastRow2
This includeds the previous comments I made. I just gave it a quick test and it is working.