I'm new to Stackoverflow so hopefully I have posted this question in the right place.
I'm having trouble getting my code to work in VBA. I want it to select columns D:F until the last cell value. With this selection, I would like to change the case of the cells (they are currently uppercase) to Proper case.
Dim Lastrow As Integer
Dim range As Variant
With Worksheets("Overdue PO")
Lastrow = .Cells(Rows.Count, "D").End(xlUp).Row
.range("D2:F" & Lastrow).Select
range = Selection.Value
End With
Application.Proper (range)
It currently selects the range until the bottom row, but it doesn't change the case of text. No error appears when running the code.
Thanks in advance :)
Try this:
Dim Lastrow As Integer
With Worksheets("Overdue PO")
Lastrow = .Cells(Rows.Count, "D").End(xlUp).Row
.Range("D2:F" & Lastrow).Value = .Evaluate("INDEX(PROPER(D2:F" & Lastrow & "),)")
End With
It will be near instant, without the need for loops.
Also using .Select or .Activate also slow down the code, aoid them if possible by referring to the cells directly.
Try this
Sub test()
Dim Lastrow As Integer
Dim range As range
Dim c As range
With Worksheets("Overdue PO")
Lastrow = Columns("D:F").Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row
.range("D2:F" & Lastrow).Select
Set range = Selection
End With
For Each c In range
c.Value = Application.WorksheetFunction.Proper(c.Value)
Next c
End Sub
Application.WorksheetFunction.Proper(range) should do it. See https://msdn.microsoft.com/en-us/library/office/ff834434.aspx for documentation on WorksheetFunction
I wanted to use this with a named range, and was kindly provided the following code. Perhaps it will assist someone else:
Sub m_MakeProper()
'2/8/2018
'
Application.Volatile True
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayStatusBar = False
'
Worksheets("test").Activate
'
Dim LastRow As Long
Dim LastCol As Integer
Dim cell As Variant
Dim thiswksht As Worksheet
Dim thiswb As Workbook
'
'
Set thiswksht = ActiveSheet
If thiswksht.AutoFilterMode Then
AutoFilterMode = False
End If
'
With thiswksht
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
End With
'
Cells(1, 1).Activate
Rows(1).find("Status").Select
Range(ActiveCell.Address, Cells(LastRow, ActiveCell.Column)).Select
Selection.Name = "c_P_Status"
With Range("c_P_Status")
.Value = Application.Evaluate("INDEX(PROPER(" & .Address & "),0)")
End With
'
End Sub
Related
I have a code that's intended to:
1) Find a name from a table using a searchbox
2) Copy cells in the row with the name on to another sheet
3) This should work for all entries in the table associated with this name.
Code sample:
Sub Printout()
Dim LR2 As Long
Dim c As Variant
Dim txt As Variant
c = InputBox("Enter Last Name")
txt = CStr(c)
Sheets("B").Select
Sheets("B").Range("K3").Value = txt
Sheets("A").Select
Sheets("A").Columns(2).Find(What:=txt, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Activate
LR2 = Sheets("A").Cells(Rows.Count, "a").End(xlUp).Row
Sheets("A").Range(Cells(ActiveCell.Row, 2), Cells(LR2, 10)).Select
Selection.Copy Destination:=Sheets("B").Range("A2:J2")
End Sub
Problem:
Currently, the code doesn't just copy the specific name from the searchbox input, but all entries under the name as well. Ie if "Johnson" is entry 3, 6, and 11, I want columns 2 to 10 for those three rows. Currently it finds the first entry and seem to copy everything in columns 2 to 10 underneath it. Can someone please help me troubleshoot this code so that I can make it do what I want?
Thanks in advance!
this should be what youre after. Season to taste but itll do what you want
Private Sub derp()
Dim this As String
this = InputBox("Enter Last Name")
Dim rng As Range
Dim rcell As Range
Dim lastrow As Long
Dim that As Variant
lastrow = ThisWorkbook.Sheets("Sheet3").UsedRange.Rows.Count
Set rng = ThisWorkbook.Sheets("Sheet2").Range("A1:a40")
For Each rcell In rng.Cells
If rcell.Value <> vbNullString Then
If rcell.Value = this Then
that = ThisWorkbook.Sheets("Sheet2").Range("A" & rcell.Row & ":H" & rcell.Row)
ThisWorkbook.Sheets("Sheet3").Range("A" & lastrow & ":H" & lastrow).Value2 = that
lastrow = lastrow + 1
End If
End If
Next rcell
End Sub
This is my best guess
Sub Printout()
Dim LR2 As Long
Dim c As Variant
Dim txt As Variant
Dim r As Range
Dim s As String
c = InputBox("Enter Last Name")
txt = CStr(c)
Sheets("B").Range("K3").Value = txt
With Sheets("A")
Set r = .Columns(2).Find(What:=txt, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
If Not r Is Nothing Then
s = r.Address
Do
LR2 = Sheets("B").Cells(Rows.Count, "a").End(xlUp).Row
.Range(.Cells(r.Row, 2), .Cells(r.Row, 10)).Copy Destination:=Sheets("B").Range("A" & LR2)
Set r = .Columns(2).FindNext(r)
Loop While r.Address <> s
End If
End With
End Sub
It is sometimes problematic to work with code, that is not created by you. In your case, you want to select and copy the cells, which you have found in column 2.
If you take a look at this code and edit it a bit, you would be able to do it.
Option Explicit
Option Private Module
Sub Printout()
Dim txt As Variant
Dim rngUnion As Range
Dim rngCell As Range
txt = "vi"
With ActiveSheet
For Each rngCell In .Range(.Cells(1, 1), .Cells(9, 1))
If InStr(1, rngCell, txt) Then
If rngUnion Is Nothing Then
Set rngUnion = .Range(.Cells(rngCell.Row, 2), .Cells(rngCell.Row, 5))
Else
Set rngUnion = Union(rngUnion, .Range(.Cells(rngCell.Row, 2), .Cells(rngCell.Row, 5)))
End If
End If
Next rngCell
End With
rngUnion.Select
End Sub
Your ActiveSheet should like this:
What the code does:
It loops through the Cells from A1 to A9.
If it finds vi in one of those cells, it adds 4 cells of the same row to a union - rngUnion
At the end it selects a union, just to show you which one is it. You can copy the selection or copy the range, without selecting it.
Good luck, have fun!
I am fairly new in excel VBA and would really appreciate any help on this matter.
The workbook includes data from range A5:AZ1000 (new client info is inputted in new rows, but some cells may be empty depending on the nature of the case). When a user inputs new client info (begins a new row) I would like the existing data (range A5:AZ1000) to shift down one row, and a blank row to appear in range A5:AZ:5. I would like users to be able to click a macro "New Client" for this to happen.
It should be noted that this is a shared workbook and therefore I cannot have macro that adds a new row.
Here is the code I'm working with:
Sub shiftdown()
' shiftdown Macro
Dim lastRow As Long
Dim lastColumn As Long
Dim rngToCopy As Range
Dim rng As Range
Set rng = ActiveSheet.Range("A1").Value
lastColumn = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
If rng > 0 Then
ActiveSheet.Range("A5" & lastRow).Select
Selection.Copy
PasteSelection.Offset(1, 0).PasteSpecial xlPasteValues
'Error Object Required
End If
End Sub
Normally I wouldn't answer if the question doesn't include any code to show effort, but I started writing the below while the question actually did show code so I may as well provide it. It may achieve what you are after.
Sub shiftdown()
' shiftdown Macro
Dim rng As Range
With ActiveSheet
If .Range("A1").Value > 0 Then
Set rng = .Range(.Cells(5, 1), _
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, _
.Cells(4, .Columns.Count).End(xlToLeft).Column))
rng.Offset(1, 0).Value = rng.Value
.Rows(5).EntireRow.ClearContents
End If
End With
End Sub
Set rng = ActiveSheet.Range("A1").Value ???
if rng is a range, then replace it by :
Set rng = ActiveSheet.Range("A1")
or if rng is a variable, replace
Dim rng As Range
by
Dim rng As variant
rng = ActiveSheet.Range("A1").Value
another error :
you declared rng as range and then you test if it is > 0
If rng > 0 Then ...
it is not possible
I'm trying to make a macro that will scroll through a spreadsheet an entire row at a time and merge all cells in the active row if they have data. It should do this until the last row.
The code currently sees all rows as empty and therefor skips them, I need an if condition or do until statement that will help detect and skip empty rows, detect rows with data and merge their cells and stop entirely when it reaches the last row.
My current code:
Sub merge()
Dim LastRow As Long, i As Long
Sheets("Body").Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows("1:1").Select
For i = 1 To LastRow
If Range("A" & i).Value = "*" Then
Selection.merge = True
Selection.Offset(1).Select
Else
Selection.Offset(1).Select
End If
Next i
End Sub
I have also tried:
sub merge2()
Dim LastRow As Long, i As Long
Sheets("Body").Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows("1:1").Select
Do Until ActiveCell.EntireRow > LastRow
'this line below was a concept
If ActiveCell.EntireRow & ActiveCell.Column.Value = "*" Then
Selection.merge = True
Selection.Offset(1).Select
Else
Selection.Offset(1).Select
End If
Loop
End Sub
This is untested but should do what you want.
Option Explicit
Sub merge()
Dim ws As Worksheet
Dim LastRow As Integer, i As Integer
Set ws = ThisWorkbook.Sheets("Body")
ws.Activate
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRow
If Not IsEmpty(Range("A" & i)) And ws.Cells(i, Columns.Count).End(xlToLeft).Column > 1 Then
ws.Rows(i & ":" & i).merge
End If
Next i
End Sub
This If will test for a) whether the cell in column A is empty and b) whether there are any other cells in that row. if statement a evaluates to false AND statement b is greater than 1 it will execute the If statement
#Tom I've taken your code and added in an error handler that makes it work without fault, thank you very much for your patience, you've been a fantastic help.
Sub merge2()
Dim ws As Worksheet
Dim LastRow As Integer, i As Integer
Set ws = ThisWorkbook.Sheets("Body")
ws.Activate
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRow
If Not IsEmpty(Range("A" & i)) And ws.Cells(i, Columns.Count).End(xlToLeft).Column >= 1 Then
On Error Resume Next
ws.Rows(i & ":" & i).merge = True
End If
Next i
End Sub
Since hours now I'm struggling with the same problem now...
I try to copy certain rows upon a condition in column A to an other Workbook. I don't get an error message, the code runs through, but nothing happens. Somehow it seems not to "see" the lines between Then and End If. If I run the code manually, the line directly jumps to End if and further repeats the loop.
Do you have any idea what could be wrong? - Thanks for any help!
This part of my code lookes like:
Dim LastRow As Integer, i As Integer
LastRow = Workbooks("Workb1.xlsx").Sheets("Sheet1").Cells(Rows.Count,"A").End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2).Value = "848" Then
Range(Cells(i, 2), Cells(i, 14)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Paste
End If
Next i
After your first comments, the edited code now is:
Dim LastRow As Integer, i As Integer
Dim ws4 As Worksheet
Set ws4 = Workbooks("Workb1").Sheets("Sheet1")
LastRow = ws4.Cells(Rows.Count, "A").End(xlUp).Row
With ws4
For i = 1 To LastRow
If .Cells(i, 1).Value = 848 Then
Range(.Cells(i, 1)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Paste
End If
Next i
End With
Ok, What I actually want to do:
Always copy from source to target sheet
First only for rows, which have a 848 in column A and paste them to target. So for all those rows, which have an 848 in column A:
Copy value in the column X in “source” --> Column Y in “target”
A --> A N-->B O-->C AM -->D AH -->G P-->I E-->J F-->K
Now, only consider those cells with a 618 in column A and copy/paste, again to the firs empty cell in this column (so after the rows with 848, now the target-sheet gets completed with the 618 cells.
A --> A N-->B O-->C AM -->D T -->G P-->I E-->J F-->K
Column E and F in the target: there are formula, which have to be elongated to the end of the column
I did change that much until now, that it's not even a working code anymore...
Private Sub CommandButton1_Click()
Dim LastRow As Integer, i As Integer, erow As Integer, LastRow2 As Integer
Dim ws4 As Worksheet
Set ws4 = Workbooks("macro_source").Sheets("Sheet1")
LastRow = ws4.Cells(Rows.Count, "A").End(xlUp).Row
With ws4
For i = 2 To LastRow
If .Cells(i, 1).Value = 848 Then
Workbooks("macro_source").Sheets("Sheet1").Activate
.Cells(i, 1).Copy
Set erow = Workbooks("destination.xlsx").Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
End If
Next i
End With
End Sub
Maybe I have to add, that both files are pre-edited by the prior code, which I did not show here. And I still did not find out whether it's possible to upload the data as excel files...
Many thanks for your help again, I really stuck...
copying between books seems to go wrong fairly often even when what you have coded seems to logically be correct.
I have found in the past it's better to reference the sheet then use the reference and to use the with statement as it seems to handle range selections better
Some code below should work for you... (I have altered the paste to start at A1 and increment each time as the original code would overwrite each time it found a value - you should be able to edit to paste where you want)
Sub CopyToNewBook()
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = Workbooks("Workb1.xlsx")
Dim wbDest As Workbook: Set wbDest = Workbooks("destination.xlsx")
If wbSrc Is Nothing Or wbDest Is Nothing Then
MsgBox "Please open both workbooks required"
Exit Sub
End If
On Error GoTo 0
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Sheets("Sheet1")
Dim wsDest As Worksheet: Set wsDest = wbDest.Sheets("Sheet1")
Dim LastRow As Long, i As Long, j As Long: j = 63976
With wsSrc
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 2 To LastRow
If .Cells(i, 1).Value = "848" Then
.Range(.Cells(i, 2), .Cells(i, 14)).Copy
wsDest.Range("A" & j).PasteSpecial xlPasteValues
j = j + 1
End If
Next i
End With
End Sub
UPDATE
For searching against multiple values
Sub CopyToNewBook()
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = Workbooks("Workb1.xlsx")
Dim wbDest As Workbook: Set wbDest = Workbooks("destination.xlsx")
If wbSrc Is Nothing Or wbDest Is Nothing Then
MsgBox "Please open both workbooks required"
Exit Sub
End If
On Error GoTo 0
Dim SearchValues() As String: SearchValues = Split("848,618", ",")
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Sheets("Sheet1")
Dim wsDest As Worksheet: Set wsDest = wbDest.Sheets("Sheet1")
Dim LastRow As Long, i As Long, j As Long, z As Long: z = 63976
With wsSrc
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For j = 0 To UBound(SearchValues)
For i = 2 To LastRow
If .Cells(i, 1).Value = SearchValues(j) Then
.Range(.Cells(i, 2), .Cells(i, 14)).Copy
wsDest.Range("A" & z).PasteSpecial xlPasteValues
z = z + 1
End If
Next i
Next j
End With
End Sub
To add to my comment
you're also counting the number of rows in column A and running the loop on column B. I'd also set your cells as it could be looking at the wrong sheet
Dim LastRow As Integer, i As Integer
Dim ws as worksheet
set ws = Workbooks("Workb1.xlsx").Sheets("Sheet1")
LastRow = ws.Cells(Rows.Count,"B").End(xlUp).Row
with ws
For i = 2 To LastRow
If .Cells(i, 2).Value = 848 Then
Range(.Cells(i, 2), .Cells(i, 14)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Paste
End If
Next i
end with
Update:
you could simplify a lot of this
Dim LastRow As Integer, i As Integer
Dim ws as worksheet
set ws = Workbooks("Workb1.xlsx").Sheets("Sheet1")
LastRow = ws.Cells(Rows.Count,"B").End(xlUp).Row
with ws
For i = 2 To LastRow
If Trim(Val(.Cells(i, 1))) = 848 Then
Range(.Cells(i, 2)).Copy _
destination:=Workbooks("destination.xlsx") _
.Worksheets("Sheet1").Range("A63976").Paste
End If
Next i
end with
This code will work fine. Check your cell that has 848 in it manually and make sure it is an integer.
Try this:
Dim LastRow As Integer, i As Integer
Dim ws4 As Worksheet
Set ws4 = Workbooks("Workb1.xlsx").Sheets("Sheet1")
LastRow = ws4.Cells(Rows.Count, "A").End(xlUp).Row
With ws4.Columns(1)
For i = 1 To LastRow
If .Cells(i).Value = 848 Then
Range(.Cells(i, 2), .Cells(i, 14)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Select
Selection.PasteSpecial
End If
Next i
End With
EDIT:
Ok, I'm sure this is frowned upon, but this is how I would have solved the issue. It's nothing close to pro-code, but it gets the work done.
Range("A1").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value = 848 Then
Range(ActiveCell.Offset(0, 1).Address(False, False), ActiveCell.Offset(0, 14).Address(False, False)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Select
Selection.PasteSpecial
End If
ActiveCell.Offset(1, 0).Select
Loop
If this code does not work, there's something else that's fishy. The code needs to be executed in the worksheet containing the list, which should be placed in column A and contain no blanks.
You can always change which sheet is selected by adding code.
I have simple problem using a sort macro. When I import data from my other Workbook, the workbook run the macro below in SheetChange and receive the run-time error.
HOWEVER, it is working completely fine if I just run the macro when the Workbook is open.
I don´t know if I have to replace Range with ActiveWorkbook or something, but I think I have tried a lot of different stuff, still without luck :(
I want it to sort from column B, starting in row 13 and until the last row/column. It is dynamic, so it will change every time I import stuff.
Sub TESTSORT()
Dim startCol, myCol As String
Dim startRow, lastRow, lastCol As Long
Dim ws As Worksheet
Dim Rng, cell As Range
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
startCol = "A"
startRow = 13
lastRow = ws.Range(startCol & ws.Rows.Count).End(xlUp).Row
'lastCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
lastCol = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
myCol = GetColumnLetter(lastCol)
Set Rng = ws.Range(startCol & startRow & ":" & myCol & lastRow)
' I GET THE ERROR HERE
Range(.Cells(13, 1), .Cells(lastRow, lastCol)).Sort key1:=Range("B13:B" & lastRow),
order1:=xlAscending, Header:=xlNo
End With
Application.ScreenUpdating = True
End Sub
Function GetColumnLetter(colNum As Long) As String
Dim vArr
vArr = Split(Cells(1, colNum).Address(True, False), "$")
GetColumnLetter = vArr(0)
End Function
It looks like you've got some issues inside your With statement... using Range instead of .Range in several places. I've tried to clean it up a bit below...
Sub TESTSORT()
Dim startCol, myCol As String
Dim startRow, lastRow, lastCol As Long
Dim ws, ws2 As Worksheet
Dim Rng, cell As Range
Set ws2 = ActiveSheet 'Preserves a reference to the active sheet as ws2
ThisWorkbook.Activate 'Makes this workbook the one that is displayed
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
startCol = "A"
startRow = 13
lastRow = .Range(startCol & .Rows.Count).End(xlUp).Row
'lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
lastCol = ws2.UsedRange.Columns(ws2.UsedRange.Columns.Count).Column
myCol = GetColumnLetter(lastCol)
Set Rng = .Range(startCol & startRow & ":" & myCol & lastRow)
' I GET THE ERROR HERE
.Range(.Cells(13, 1), .Cells(lastRow, lastCol)).Sort key1:=.Range("B13:B" & lastRow),
order1:=xlAscending, Header:=xlNo
End With
Application.ScreenUpdating = True
End Sub
Function GetColumnLetter(colNum As Long) As String
Dim vArr
vArr = Split(Cells(1, colNum).Address(True, False), "$")
GetColumnLetter = vArr(0)
End Function