I am trying to create a macro that the user will enter their initials in a specific cell and the macro will copy the initials and paste them into a list on another tab. I am having a hard time figuring out how to convert it over to upper case any help is greatly appreciated below is my code. Thanks in advance!
'By Initials
Worksheets("New PN").Activate
Range("B10").Copy
Sheets("PN_List").Select
Range("F1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues
Selection.HorizontalAlignment = xlCenter
With Selection.Font
.Name = "Calibri"
.Size = 11
End With
right-click your sheet tab PN New
View Code
copy and paste the code below
This code will then automatically add any new value/s from B10 and B12 (second cell used as an example so the code can run on a range if needed) into the first blank cell in column F on sheet *PN_List*
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim lngCnt As Long
Set rng1 = Intersect(Range("B10,B12"), Target)
If rng1 Is Nothing Then Exit Sub
Set rng3 = Sheets("PN_List").Columns("F:F").Find("*", Sheets("PN_List").[f1], xlValues, , xlPrevious, xlByRows)
If rng3 Is Nothing Then Set rng3 = Sheets("PN_List").[f1]
For Each rng2 In rng1
rng3.Offset(lngCnt + 1, 0) = UCase$(rng2)
lngCnt = lngCnt + 1
Next rng2
End Sub
Use the UCASE function. this works for me
ActiveCell = UCase(ActiveCell)
Use Ucase function like this:
Dim initial as String
initial = Ucase(Range("B10").Value)
Range("F1").End(xlDown).Offset(1, 0).Value = initial
Hope this helps.
Related
I have a template file that I will use to populate more files and I need to hide some rows according to what its selected, but at the same time I can't hide other rows. I can do it well if the data stay the same size all the time, but the file will be increasing and decreasing depending on the information.
I have a range of values in Column C. What I tried to do is to look for the cell value that contains "Pack" (It will be same for all files). From that cell that contains "Pack" (let's assume that is at C8 now, but can be in C30 in other file) I need to start looking for values that are not equal to the one that I have from a droplist (rowing) and hide the rows.
Maybe better explained, also I tried to do was to assign a variable that will hold the value of the droplist and just look for values that was not equal and simply hide it. Then do a .Find() to find the "Pack" word. Once it was found, get the cell address. Finally take that address and use it as a parameter in Range() as yo can see in the code that I wrote: For Each cell In Range("packR:C5") and I know that is very wrong because I can't pass that.
Dim cell As Range
Dim pack As Range
rowing = Range("A2").Value
Set pack = Range("C1:C12").Find("Pack")
Set packA = Range(pack.Address)
Set packR = packA
For Each cell In Range("packR:-end point here")
cell.EntireRow.Hidden = False
If Not IsEmpty(cell) Then
If cell.Value <> rowing Then
cell.EntireRow.Hidden = True
End If
End If
Next
I have very little vba background but with research I can understand a few. Basically the goal is to ignore all the rows in top of "Pack" and start looking from "Pack" (That need to have a cell address) to the end of the excel file. The biggest issue is to take that cell address and use it as parameter to the Range ("":"").
I think you're looking for something like this. Note the comment about specifying the other parameters of Range.Find.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
Dim lastCell As Range
Set lastCell = ws.Cells(ws.Rows.Count, "C").End(xlUp)
If Not pack Is Nothing Then '<--- tests to see if pack was found
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
EDIT:
End(xlUp) will not find the true last row if rows are already hidden. To get around this, here are two options:
Unhide all rows after finding "Pack".
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
If Not pack Is Nothing Then '<--- tests to see if pack was found
ws.UsedRange.EntireRow.Hidden = False '<--- unhide all rows so as to find the last cell properly
Dim lastCell As Range
Set lastCell = ws.Cells(ws.Rows.Count, "C").End(xlUp)
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
Use an alternate way of finding the last cell:
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
Dim lastCell As Range
Set lastCell = GetLastCell(ws, 3)
If Not pack Is Nothing Then '<--- tests to see if pack was found
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
Private Function GetLastCell(ByVal ws As Worksheet, Optional ByVal colNum As Long = 1) As Range
With ws
Dim lastCell As Range
Set lastCell = .Columns(colNum).Find(What:="*", _
After:=.Cells(1, colNum), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If lastCell Is Nothing Then
Set lastCell = .Cells(1, colNum)
End If
End With
Set GetLastCell = lastCell
End Function
I have my data in columns A:L in Sheet2 and wish to copy each block based on the starting point, as certain cell text and the end point, again as certain cell text!
So in the example the cell start text should be "Tank Engine" and the cell end text would be "INFORMATION: Tank Engine". Therefore, column A:L, rows 1:18 should be copied into Sheet3 at cell A1, but only where the cell text exists as this can be dynamic. I need to reference column A to paste to in Sheet3, and copy only the rows that begin with "Tank Engine" and end with "INFORMATION: Tank Engine", which are rows 1:18. The next block would be Columns A:L, rows 25:41 based on the string "Weatherman" and this being pasted into Sheet3 Cell M:X etc.....
The rows are dynamic the columns are static..... I have tried many many snippets of VBA but this is quite particular so cannot find a good match!!
Sub Mike4()
Dim i As Long
lastcolumn = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To lastcolumn
If Cells(1, i) = "Tank Engine" Then
'lastrow = Columns(i).SpecialCells(xlLastCell).Row
lastRow = Columns(i).Find("INFORMATION: Tank Engine").Row
Range(Cells(2, i), Cells(lastRow, i)).Copy Sheet3.Range("A" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Next i
End Sub
I am trying to get the above to then paste the columns with the rows affected into a specific cell then to search for Weatherman as described above but need a starting point that something is working then be able to build on that...As stated previously I have lots of snippets of code but none accumulatively work for what I want to achieve if at all. Any help would be greatly appreciated!! Thanks in advance...Many Thanks!!
Look at this example:
Option Explicit
Sub CopyMyStuff()
Dim wsSrc As Worksheet
Set wsSrc = ThisWorkbook.Worksheets("SourceSheet")
Dim wsDest As Worksheet
Set wsDest = ThisWorkbook.Worksheets("Sheet3")
'find start
Dim FoundStart As Range
Set FoundStart = wsSrc.Range("A:L").Find(What:="Tank Engine", LookAt:=xlWhole)
If FoundStart Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
'find end
Dim FoundEnd As Range
Set FoundEnd = wsSrc.Range("A:L").Find(What:="INFORMATION: Tank Engine", LookAt:=xlWhole, After:=FoundStart)
If FoundEnd Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
wsSrc.Range(FoundStart, FoundEnd).Resize(ColumnSize:=12).Copy wsDest.Range("A1")
End Sub
Or more elegant with a function:
Option Explicit
Sub CopyMyStuff2()
Dim wsSrc As Worksheet 'define source
Set wsSrc = ThisWorkbook.Worksheets("SourceSheet")
Dim wsDest As Worksheet 'define destination
Set wsDest = ThisWorkbook.Worksheets("Sheet3")
Dim FindList As Variant 'defind search words
FindList = Array("Tank Engine", "Weatherman")
Dim i As Long
Dim FindItm As Variant
For Each FindItm In FindList
Dim CopyRange As Range
Set CopyRange = FindMyRange(wsSrc.Range("A:L"), FindItm, "INFORMATION: " & FindItm)
If Not CopyRange Is Nothing Then
CopyRange.Copy wsDest.Range("A1").Offset(ColumnOffset:=i) 'note that if the first column uses merged cells the ColumnOffset:=i otherwise it is ColumnOffset:=i*12
i = i + 1
End If
Next FindItm
End Sub
Function FindMyRange(SearchInRange As Range, ByVal StartString As String, ByVal EndString As String) As Range
'find start
Dim FoundStart As Range
Set FoundStart = SearchInRange.Find(What:=StartString, LookAt:=xlWhole)
If FoundStart Is Nothing Then GoTo ERR_NOTHING_FOUND
'find end
Dim FoundEnd As Range
Set FoundEnd = SearchInRange.Find(What:=EndString, LookAt:=xlWhole, After:=FoundStart)
If FoundEnd Is Nothing Then GoTo ERR_NOTHING_FOUND
Set FindMyRange = SearchInRange.Parent.Range(FoundStart, FoundEnd).Resize(ColumnSize:=12)
Exit Function
ERR_NOTHING_FOUND:
FindMyRange = Nothing
End Function
I'm trying to create a VBA Macro that would search for a non-blank cell in "Sheet1" and if non-blank, it would paste the respective active cell column from "Sheet1" to the same column in "Sheet2".
Below is my code, but I'm sure I'm doing something wrong, because the code is throwing me an error : 1004.
Sub Test()
Dim cel As Range
Dim strAddress As String
Dim StartPoint As Range
Set StartPoint = ActiveCell
'Change to necessary amount of Rows & Columns
With Sheets("Sheet1").Range(Cells(9, 5), Cells(1000, 200))
Set cel = .Find(What:="*", After:=Cells(1000, 200), SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not cel Is Nothing Then
strAddress = cel.Address
Do
' Do something with cel, e.g.
StartPoint.EntireColumn.Copy Destination:=Worksheets("Sheet2").Range(StartPoint.Column & "1").End(xlToRight).Offset(1)
Set cel = .FindNext(After:=cel)
If cel Is Nothing Then Exit Do
Loop Until cel.Address = strAddress
End If
End With
End Sub
Can someone kindly advise what I'm doing wrong?
Thank you!
Try these two modifications:
With Sheets("Sheet1").Range("E9:GR1000")
.
cel.EntireColumn.Copy Worksheets("Sheet2").Columns(cel.Column)
In various places in column E of spreadsheet "Review" I have variables that start with the word "Sustainability:" (e.g., Sustainability: a, Sustainability:B"). Each time it finds one. I want it to copy the cell that is in the same row but two columns to the right. Then I want it to paste into a different sheet (SPSE Tran), starting at B63. Each time it pastes, the destination needs to offset by 1 row so it can paste down until it finds no more "Sustainability:". The code below is a start to this but I am stuck.
The second thing I need it to do (which I don't even know where to start) is to only iterate doing this until it finds a row that says "ONLY FOR TRANSITIONS". This leads into a new section that also includes "Sustainability:" but I don't want it to copy from there.
Thank you!
Sub SubmitData()
Dim RngA As Range
Dim FirstAd As String
Dim DestAd As Range
With Sheets("Review").Range("E:E")
Set RngA = .Find(What:="Sustainability:", lookat:=xlPart)
Set DestAd = Range("B63")
If Not RngA Is Nothing Then
FirstAd = RngA.Address
Do
Range(Cell, Cell.Offset(0, 2)).Copy _
Destination:=Sheets("SPSE Tran").Range(DestAd)
Set RngA = .FindNext(RngA)
Set DestAd = DestAd.Offset(0, 1)
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd
End If
End With
End Sub
Here's your code revamped to use a filter instead of a find loop, and then it gets all the results and copies them to the destination at once:
Sub SubmitData()
Dim ws As Worksheet
Dim rngDest As Range
Dim rngStop As Range
With Sheets("SPSE Tran")
Set rngDest = .Cells(Rows.Count, "B").End(xlUp)
If rngDest.Row < 63 Then Set rngDest = .Range("B63")
End With
Set ws = Sheets("Review")
Set rngStop = ws.Columns("A").Find("ONLY FOR TRANSITIONS", , xlValues, xlPart)
With ws.Range("E1:E" & rngStop.Row)
.AutoFilter 1, "Sustainability:*"
.Offset(1, 2).Copy rngDest
.AutoFilter
End With
End Sub
How about (untested):
RngB = where you find "ONLY FOR TRANSITIONS"
RngBRow = RngB.Row
then change your Loop While .. to
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd And RngA.Row < RngBRow
I am trying to create a macro in excel 2010 that finds every cell in a sheet with a value of "All Customers." Every time that value is found I need a blank row inserted below it. Thought it would be pretty simple but I have searched I many forums and tried to use some sample code and I can't get it to work properly. I am a complete newb when it comes to VBA stuff. Thought I would post here and go do some light reading on basics of VBA.
If anyone has any good training resources, please post those as well.
Thanks in advance!
EDIT: In my OP, I neglected to mention that any row that contains a value of "All Customers" would ideally be highlighted and put in bold, increased size font.
These actions are something that an old Crystal Report viewing/formatting program used to handle automatically when pulling the report. After we upgraded the program I learned that this type of formatting ability had been removed with the release of the newer version of the program, according to the software manufacturer's tech support. Had this been defined in the release notes I would have not performed the upgrade. Regardless, that is how I found myself in this macro disaster.
Something like this code adpated from an article of mine here is efficient and avoids looping
It bolds and increase the font size where the text is found (in the entire row, as Tim points out you should specify whether you meant by cell only)
It adds a blank row below the matches
code
Option Explicit
Const strText As String = "All Customers"
Sub ColSearch_DelRows()
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim cel1 As Range
Dim cel2 As Range
Dim strFirstAddress As String
Dim lAppCalc As Long
Dim bParseString As Boolean
'Get working range from user
On Error Resume Next
Set rng1 = Application.InputBox("Please select range to search for " & strText, "User range selection", ActiveSheet.UsedRange.Address(0, 0), , , , , 8)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
'Further processing of matches
bParseString = True
With Application
lAppCalc = .Calculation
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'a) match string to entire cell, case insensitive
'Set cel1 = rng1.Find(strText, , xlValues, xlWhole, xlByRows, , False)
'b) match string to entire cell, case sensitive
'Set cel1 = rng1.Find(strText, , xlValues, xlWhole, xlByRows, , True)
'c)match string to part of cell, case insensititive
Set cel1 = rng1.Find(strText, , xlValues, xlPart, xlByRows, , False)
'd)match string to part of cell, case sensititive
' Set cel1 = rng1.Find(strText, , xlValues, xlPart, xlByRows, , True)
'A range variable - rng2 - is used to store the range of cells that contain the string being searched for
If Not cel1 Is Nothing Then
Set rng2 = cel1
strFirstAddress = cel1.Address
Do
Set cel1 = rng1.FindNext(cel1)
Set rng2 = Union(rng2.EntireRow, cel1)
Loop While strFirstAddress <> cel1.Address
End If
'Further processing of found range if required
If bParseString Then
If Not rng2 Is Nothing Then
With rng2
.Font.Bold = True
.Font.Size = 20
.Offset(1, 0).EntireRow.Insert
End With
End If
End If
With Application
.ScreenUpdating = True
.Calculation = lAppCalc
End With
End Sub
Public Sub InsertRowAfterCellFound()
Dim foundRange As Range
Set foundRange = Cells.Find(What:="yourStringOrVariant", After:=ActiveCell) 'Find the range with the occurance of the required variant
Rows(foundRange.Row + 1 & ":" & foundRange.Row + 1).Insert 'Insert a new row below the row of the foundRange row
foundRange.Activate 'Set the found range to be the ActiveCell, this is a quick and easy way of ensuring you aren't repeating find from the top
End Sub
You may need to add error handling to the code as you will get an error if no cell with the specified value is found.
Assuming this is on the first sheet ("sheet 1"), here is a slow answer:
Sub InsertRowsBelowAllCustomers()
'Set your worksheet to a variable
Dim sheetOne as Worksheet
Set sheetOne = Worksheets("Sheet1")
'Find the total number of used rows and columns in the sheet (where "All Customers" could be)
Dim totalRows, totalCols as Integer
totalRows = sheetOne.UsedRange.Rows.Count
totalCols = sheetOne.UsedRange.Columns.Count
'Loop through all used rows/columns and find your desired "All Customers"
Dim row, col as Integer
For row = 1 to totalRows
For col = 1 to totalCols
If sheetOne.Cells(row,col).Value = "All Customers" Then
Range(sheetOne.Cells(row,col)).Select
ActiveCell.Offset(1).EntireRow.Insert
totalRows = totalRows + 1 'increment totalRows because you added a new row
Exit For
End If
Next col
Next row
End Sub
This function starts from the last row and goes back up to the first row, inserting an empty row after each cell containing "All Customers" on column A:
Sub InsertRowsBelowAllCustomers()
Dim R As Integer
For R = UsedRange.Rows.Count To 1 Step -1
If Cells(R, 1) = "All Customers" Then Rows(R + 1).Insert
Next R
End Sub
The error is because the worksheet was not specified in used range.
I have slightly altered the code with my text being in column AJ and inserting a row above the cell.
Dim R As Integer
For R = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If Range("AJ" & R) = "Combo" Then Rows(R).Insert
Next R