I'm trying to loop through each worksheet in my workbook and change the text in column G to upper case, with the header column remaining unchanged.
Sub capitalize_columns()
Dim wb as ThisWorkbook
Dim ws as Worksheet
set wb = ThisWorkbook
For Each ws in wb.worksheets
With ws
Dim last_row as Long
last row = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim capital_range As Range
Set capital_range = ws.Range("G2:G" & last_row)
capital_range.Value = capital_range.Parent.Evaluate("Index(UPPER(" & name_range.Address & "),)")
End With
Next ws
End Sub
The script runs but I it doesn't produce my desired result of capitalizing the everything in column G with the exception of the header.
I think you are overcomplicating the upper case part. All you need is UCase() in a loop like shown here:
Sub capitalize_columns()
Dim ws As Worksheet
Dim row As Long
Dim last_row As Long
For Each ws In ThisWorkbook.Worksheets
With ws
last_row = .Cells(.Rows.Count, 1).End(xlUp).Row ' use column A to find last row
For row = 2 To last_row ' start at row 2
.Range("G" & row) = UCase(.Range("G" & row))
Next
End With
Next ws
End Sub
Your code is good! Index(UPPER()) is a faster way as it doesn't loop as mentioned in Convert an entire range to uppercase without looping through all the cells. Your code just needs few fixes.
Fixes:
Declare the objects on the top and not in the loop.
Find the last row of column G and not A. You may not get the true range if the column data is uneven.
Use Option Explicit. It will catch typos like last_row Vs last row and also name_range
Code:
Option Explicit
Sub capitalize_columns()
Dim wb As ThisWorkbook
Dim ws As Worksheet
Dim last_row As Long
Dim capital_range As Range
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
With ws
'~~> Find last row in col G
last_row = .Cells(.Rows.Count, 7).End(xlUp).Row
Set capital_range = .Range("G2:G" & last_row)
capital_range.Value = .Evaluate("Index(UPPER(" & capital_range.Address & "),)")
End With
Next ws
End Sub
Related
Complete beginner for VBA so simpler the better.
I want to collect all sheet names in excel and insert them to the first row. I'm able to collect the names with macro that I found (bellow) but I don't know how to convert the values to be in the first row only and not in the first column?
Sub TestNames()
Dim Ws As Worksheet
Dim LR As Long
For Each Ws In ActiveWorkbook.Worksheets
LR = Worksheets("Worksheet Names").Cells(Rows.Count, 1).End(xlUp).Row + 1
'This LR varaible to find the last used row
Cells(LR, 1).Select
ActiveCell.Value = Ws.Name
Next Ws
End Sub
https://www.wallstreetmojo.com/vba-name-worksheet/#:~:text=In%20VBA%2C%20to%20name%20a,its%20name%20using%20Worksheet%20object.
Worksheet Names to First Row
Option Explicit
Sub TestNames()
Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets("Worksheet Names")
Dim sws As Worksheet
Dim c As Long
For Each sws In ThisWorkbook.Worksheets
c = c + 1
dws.Cells(1, c).Value = sws.Name
Next sws
End Sub
Very close, just check for last column, and re-arrange Cells(LR, 1).Select
like in example below.
Keep in mind, finding last row and last column is not very straight forward task, there are different methods, - investigate them and apply the one which fits the best.
Sub TestNames()
Dim Ws As Worksheet
Dim LastColumn As Long
For Each Ws In ActiveWorkbook.Worksheets
'LR = Worksheets("Worksheet Names").Cells(Rows.Count, 1).End(xlUp).Row + 1
LastColumn = Worksheets("Worksheet Names").Cells(1, Worksheets("Worksheet Names").Columns.Count).End(xlToLeft).Column + 1
Worksheets("Worksheet Names").Cells(1, LastColumn).Value = Ws.Name
Next Ws
End Sub
I need to select a Range from after Last Row till end of usedRange.
The below code works, But is there Proper /Shorter code.
Option Explicit
Sub Select_Blank_in_Usedrange()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim LastR As Long, LastR_UsedRange As Long
LastR = ws.Cells(Rows.Count, "A").End(xlUp).Row
LastR_UsedRange = ws.UsedRange.Rows.Count
ws.Range("A" & LastR + 1, "AE" & LastR_UsedRange).Select
End Sub
If the code works and has no redundant parts, I would say it's good. If I were to suggest an improvement, it would be to save the relevant addresses as Range Objects instead of Row numbers. This way you can assemble the larger range directly from the two corners, instead of having to concatenate the address in the final step.
Sub Select_Blank_in_Usedrange()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim TopCorner As Range
Set TopCorner = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
Dim BottomCorner As Range
With ws.UsedRange.Columns(31)
Set BottomCorner = .Cells(.Cells.Count)
End With
ws.Range(TopCorner, BottomCorner).Select
End Sub
To me, this is much clearer, and the constants are clearly displayed. This will make it easier to edit later, if the number of columns changes, or if the starting column moves from "A".
The shortest code will be the next:
Dim ws As Worksheet: Set ws = ActiveSheet
ws.Range("A" & ws.Range("A" & ws.rows.count).End(xlUp).row + 1, _
"AE" & ws.UsedRange.rows.count + ws.UsedRange.cells(1).row - 1).Select
It will also deal with the case when UsedRange does not start from the first row...
I have user running a macro that formats specific worksheets within a workbook. After running this macro, the user has trailing zeros that generate in multiple worksheets and they are looking for a way to remove those zeros from each worksheet.
Initially, I provided them with the vba below but this is only useful for a single worksheet.
I was curious if there was an easy way to alter the VBA below to accommodate multiple worksheets, or would I need to rewrite the VBA altogether.
I have provided an image that will hopefully help visualize what I mean by trailing zeros....Feel free to request additional information. Thank you ahead of time for the help!
Sub contentkiller()
Dim lastRow As Long
With ActiveSheet
'Find last row in col C
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'clear data
.Range("A" & lastRow + 1 & ":Y" & .Rows.Count).ClearContents
End With
End Sub
Trailing Zeros at the Bottom of a Dataset
You can just loop through all worksheets. Hopefully they are similar in structure. Something like this should work.
Sub runAll()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Call contentkiller(ws)
Next ws
End Sub
Private Sub contentkiller(ws As Worksheet)
Dim lastRow As Long
With ws
'Find last row in col C
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'clear data
.Range("A" & lastRow + 1 & ":Y" & .Rows.Count).ClearContents
End With
End Sub
Remove Trailing...
In each worksheet of a workbook, it will find the bottom-most non-empty cell in the first column of its used range. If the cell is located above the bottom-most cell(s) of the used range, it will clear the contents in all of the rows of the used range, that are below the found cell.
Option Explicit
Sub RemoveTrailing()
Dim wb As Workbook: Set wb = ActiveWorkbook
' If you plan to copy this code into each workbook then use:
'Set wb = ThisWorkbook
Dim ws As Worksheet
Dim crg As Range
Dim lCell As Range
Dim lRow As Long
Dim ulRow As Long
For Each ws In wb.Worksheets
With ws.UsedRange
With .Columns(1)
Set lCell = Nothing
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
End With
If Not lCell Is Nothing Then
lRow = lCell.Row
ulRow = .Row + .Rows.Count - 1
If lRow < ulRow Then
Set crg = .Rows(lRow - .Row + 2).Resize(ulRow - lRow)
crg.ClearContents
End If
'Else
' empty first column
End If
End With
Next ws
End Sub
I have this code, by a responder who helped me to define my needs yesterday - but there somethings i want to change, but my vba skills are very low and dont know how and where to modify the code. I want it do 2 Things.
Right know it transferes data, i want it to copy it, over with the values that are calculated in the cells. I have some cells, where i have some formulas and it dosent follows with it. I just want the calculated value over. I dont know if i can use xlPasteValues somewhere to get what i want?
The second thing that i want is, when copying over, i want to be on top and the previous copies move Down, so the latest copy always are in the top.
Thank you before handed :)
Option Explicit
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
targetSheet.Columns.AutoFit
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
Please give this a try...
The StartRow variable defines the destination row on targetSheet, you may change it as per your requirement.
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Dim StartRow As Integer
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
StartRow = 1 'Destination row on targetSheet
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
.Range("A1").CurrentRegion.Copy
targetSheet.Range("A" & StartRow).Insert shift:=xlDown
targetSheet.Range("A" & StartRow).PasteSpecial xlPasteValues
targetSheet.Columns.AutoFit
End With
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
substitute
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
with
With .Range("A1").CurrentRegion
targetSheet.Rows(1).Resize(.Rows.Count).Insert shift:=xlUp
targetSheet.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
I am trying to copy rows from Sheet1 which meet a crieteria and post the whole row at the end of the current data. I am able to copy the row but it is not pasting it. Help will be appreciated. Here is my code I have written:
Sub Button1_Click()
Dim i As Integer
'Range("H2:O65536").ClearContents
Sheets("Sheet1").Select
LastRowColA = Range("A65536").End(xlUp).Row
For i = 2 To LastRowColA
If Cells(i, 6) = "No" Then
Rows(i).Select
Rows(i).Copy
Sheets("Sheet2").Select
Dim LastRow As Long
Dim StartRow As Long
Dim Col As Long
Dim Row As Long
StartRow = 2
Col = 1
LastRow = findLastRow(1)
For Row = StartRow To LastRow
Rows(LastRow).Select
ActiveSheet.Paste
Next Row
Else
'do nothing
End If
Next i
End Sub
Function findLastRow(ByVal Col As Integer) As Long
'Find the last row with data in a given column
findLastRow = Cells(Rows.Count, Col).End(xlUp).Row
End Function
here we go: a tad shorter, but should do the job...
Sub Button1_Click()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
For i = 2 To ws1.Range("A65536").End(xlUp).Row
If ws1.Cells(i, 6) = "No" Then ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 6).End(xlUp).Row + 1)
Next i
End Sub
To add a bit more help, why spend all that (processing) time looping through a potentially large row set when you can just filter and copy all your data at once?
See code below. You may need to tweak it a bit to match your data set.
Sub Button1_Click()
Dim ws1 as Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 as Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws1
.UsedRange.AutoFilter 6, "No"
'-> assumes data starts in column A, if not adjust the 6
Intersect(.UsedRange,.UsedRange(Offset(1)).SpecialCells(xlCellTypeVisible).Copy
' -> assumes No's are there, if they may not exist, will need to error trap.
End With
With ws2
.Rows(.Cells(ws2.Rows.Count, 6).End(xlUp).Row + 1).PasteSpecial xlPasteValues
End With
ws1.AutoFilterMode = False
End Sub
// Just use it.
Sheet2.Select (Sheet1.Rows(index).Copy)
Sheet2.Paste (Rows(index))
If you want to copy, paste two or more rows then use the for loop.