My cell values are strings of numbers (always greater than 5 numbers in a cell, ie 67391853214, etc.)
If a cell starts with three specific numbers (ie 673 in a cell value 67391853214) I want the data in the cell to be replaced with a different value (if 673 are the first numbers, replace entire cell value with "790")
I know there's a way to use an asterick to use only part of the cell value but I'm not 100% on the syntax. This is the current code I have, but it's searching for specifically "###*", not values that start with "###". Any and all help is greatly appreciated!
lastRow = Range("A" & Rows.Count).End(xlUp).Row
colNum = WorksheetFunction.Match("Number", Range("A1:CC1"), 0)
For Each c In Range(Cells(2, colNum), Cells(lastRow, colNum))
If c.Value = "614*" _
Or c.Value = "626*" _
Or c.Value = "618*" _
Or c.Value = "609*" _
Or c.Value = "605*" Then
c.Value = "737"
`
Use the LEFT() function, as shown below:
lastRow = Range("A" & Rows.Count).End(xlUp).Row
colNum = WorksheetFunction.Match("Number", Range("A1:CC1"), 0)
For Each c In Range(Cells(2, colNum), Cells(lastRow, colNum))
If LEFT(c.Value,3) = "614" _
Or LEFT(c.Value,3) = "626" _
Or LEFT(c.Value,3) = "618" _
Or LEFT(c.Value,3) = "609" _
Or LEFT(c.Value,3) = "605" Then
c.Value = "737"
Better to do a range replace rather than loop through each cell for speed:
Dim rng1 As Range
Dim LastRow As Long
Dim ColNum As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next
ColNum = Application.Match("Number", Range("A1:CC1"), 0)
On Error GoTo 0
If Column Is Nothing Then Exit Sub
Set rng1 = Range(Cells(2, ColNum), Cells(LastRow, ColNum))
With rng1
.Replace "626*", "727", xlWhole
.Replace "618*", "727", xlWhole
.Replace "609*", "727", xlWhole
.Replace "737*", "727", xlWhole
End With
Here is my take on the problem:
Sub SO()
Dim MyString As String
MyString = "614,626,618,609,605"
For X = 1 To Range("C" & Rows.Count).End(xlUp).Row
If Replace(MyString, Left(Range("C" & X).Value, 3), "") <> MyString Then Range("C" & X).Value = "737"
Next
End Sub
Related
In the each cell in a column I have this information in the cells:
A1 values:
Depth=standard;Size=1 section;Doors=hinged solid;Interior configuration=shelves;Compressor HP=1/2 HP;Interior finish=stainless steel;Exterior finish=stainless steel;Refrigeration=top mount self-contained
A2 values:
Top openings= 6 pan;Size=1 section;Compressor HP=1/6 HP;Style=drawers;Exterior finish=stainless steel;Interior finish=stainless steel;Refrigeration=rear mounted
A3,A4,A5 etc all follow similar formats
I need some method of abstracting out the following information into its own cells:
I need each semicolon separated value to be checked if there is a column name for it already, if not, make a new column and put all corresponding values where they need to be
I thought about using text->columns and then using index/match but I haven't been able to get my match criteria to work correctly. Was going to do this for each unique column. Or do I need to use VBA?
You could go with something like this, though you'll have to update the sheet name and probably where you want the final data located.
Sub SplitCell()
Dim DataFromCell, FoundCell
Dim Testing, Counted, LastCol
For Each c In Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
Testing = Split(c.Value, ";")
Range("B" & c.row + 1).Value = "A" & c.row
Counted = UBound(Testing)
For Each x In Testing
DataFromCell = Split(x, "=")
With Sheet2
Set FoundCell = .Cells.Find(What:=DataFromCell(0), after:=.Cells(1, 2), _
LookIn:=xlValues, lookat:=1, searchorder:=xlByColumns, searchdirection:=xlNext, _
MatchCase:=False, searchformat:=False)
End With
If Not FoundCell Is Nothing Then
Cells(c.row + 1, FoundCell.Column).Value = DataFromCell(1)
End If
If FoundCell Is Nothing Then
LastCol = Sheet2.Cells(1, Sheet2.Columns.count).End(xlToLeft).Column
Cells(1, LastCol + 1).Value = DataFromCell(0)
Cells(c.row + 1, LastCol + 1).Value = DataFromCell(1)
End If
Next x
Next c
End Sub
Edit
Since the above was giving you errors you could try this one:
Sub SplitCell()
Dim DataFromCell, FoundCell
Dim Testing, Counted, LastCol
For Each c In Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
Testing = Split(c.Value, ";")
Range("B" & c.row + 1).Value = "A" & c.row
Counted = UBound(Testing)
For Each x In Testing
DataFromCell = Split(x, "=")
LastCol = Sheet2.Cells(1, Sheet2.Columns.count).End(xlToLeft).Column
With Sheet2
FoundCell = Application.Match(DataFromCell(0), Range(Cells(1, 2), Cells(1, LastCol)), 0)
'Set FoundCell = .Cells.Find(What:=DataFromCell(0), after:=.Cells(1, 2), _
LookIn:=xlValues, lookat:=1, searchorder:=xlByColumns, searchdirection:=xlNext, _
MatchCase:=False, searchformat:=False)
End With
If Not IsError(FoundCell) Then
Cells(c.row + 1, FoundCell + 1).Value = DataFromCell(1)
End If
If IsError(FoundCell) Then
Cells(1, LastCol + 1).Value = DataFromCell(0)
Cells(c.row + 1, LastCol + 1).Value = DataFromCell(1)
End If
Next x
Next c
End Sub
Only changed a few things so that it is using Match instead of Find
My solution below works as intended but the data wasn't as formatted as I originally thought.
Option Explicit
Private Sub Auto_Open()
MsgBox ("Welcome to the delimiter file set.")
End Sub
'What this program does:
'http://i.imgur.com/7MVuZLt.png
Sub DelimitFilter()
Dim curSpec As String
Dim curSpecArray() As String
Dim i As Integer, IntColCounter As Integer, iCounter As Integer, argCounter As Integer
Dim WrdString0 As String, WrdString1 As String
Dim dblColNo As Double, dblRowNo As Double
Worksheets(1).Activate
'Reference to cell values that always have data associated to them
Range("W2").Activate
'checks for number of arguments to iterate through later
Do
If ActiveCell.Value = "" Then Exit Do
ActiveCell.Offset(1, 0).Activate
argCounter = argCounter + 1
Loop
'Check # of arguments
Debug.Print (argCounter)
'Values to delimit
Range("X2").Activate
IntColCounter = 1
'Loop each row argument
For iCounter = 0 To argCounter
'Set var to activecell name
dblColNo = ActiveCell.Column
dblRowNo = ActiveCell.Row
'Grab input at active cell
curSpecArray() = Split(ActiveCell.Value, ";")
'Ignore empty rows
If Not IsEmpty(curSpecArray) Then
'Iterate every delimited active cell value at that row
For i = LBound(curSpecArray) To UBound(curSpecArray)
'Checks for unique attribute name, if none exists, make one
WrdString0 = Split(curSpecArray(i), "=")(0)
'a large range X1:ZZ1 is used as there are many unique column names
If IsError(Application.Match(WrdString0, Range("X1:ZZ1"), 0)) Then 'if NOT checks if value exists
Cells(1, dblColNo + IntColCounter).Value = WrdString0
IntColCounter = IntColCounter + 1
End If
'Output attribute value to matching row and column
WrdString1 = Trim(Split(curSpecArray(i), "=")(1))
Debug.Print (WrdString1)
Cells(dblRowNo, -1 + dblColNo + Application.Match(WrdString0, Range("X1:ZZ1"), 0)).Value = WrdString1
Next i
End If
'Iterate Next row value
ActiveCell.Offset(1, 0).Activate
Next iCounter
End Sub
I would like to have some tips to start a VBA code:
I have 2 sheets. Each row of the sheet(2) has text in each cells but between them it can have some empty cell.
My goal is to copy start from the row1 of sheet(2) from A1 to E1 and past it in the sheet(1) row 1 but without empty cell between them.
I edit my post because i did not thought about this important details. I would like to erase any duplicate in the same row but to keep the first entry.
And repeat the operation until the last row.
Data exemple:
Worksheet(2):
row1 cell1, cell2, cell3,cell4,cell5:
**ABC**, ,DEF,**ABC**,GHI
row(2) cell1, cell2, cell3,cell4,cell5:
ZZZ, , , ,YEU
Resultat expected:
Worksheet(1):
row1 cell1, cell2, cell3,cell4,cell5:
**ABC**,DEF,GHI, , ,
row(2) cell1, cell2, cell3,cell4,cell5:
ZZZ,YEU, , ,
Thank you for your help in advance!
Try this:
Sub stack_overflow()
Dim lngLastRow As Long
Dim xNum As Long
Dim xCell As Range
Dim shtFrom As Worksheet
Dim shtTo As Worksheet
Dim lngColCount As Long
'Change the two lines below this to change which sheets you're working with
Set shtFrom = ActiveWorkbook.Sheets(2)
Set shtTo = ActiveWorkbook.Sheets(1)
lngLastRow = shtFrom.Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
For xNum = 1 To lngLastRow
lngColCount = 1
For Each xCell In shtFrom.Range("A" & xNum & ":E" & xNum)
If xCell.Value <> "" Then
If shtTo.Range("A" & xNum & ":E" & xNum).Find(What:=xCell.Value, LookIn:=xlValues, Lookat:=xlWhole) Is Nothing Then
shtTo.Cells(xNum, lngColCount).Value = xCell.Value
lngColCount = lngColCount + 1
End If
End If
Next xCell
Next xNum
End Sub
I found it:
Sub M()
lastrow = Sheets("Sheet2").Range("A1").SpecialCells(xlCellTypeLastCell).Row
For i = 1 To lastrow
Sheets("Sheet2").Range("A" & i & ": M" & i).Copy Sheets("Sheet1").Range("A" & i) ' Change Column M as required
Sheets("Sheet1").Range("A" & i & ": M" & i).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
Next
End Sub
You are going to have to provide some string manipulation after collecting the values from each row in order to remove the blanks.
Sub contract_and_copy()
Dim rw As Long, lr As Long, lc As Long, ws As Worksheet
Dim sVALs As String, vVALs As Variant
Set ws = Sheets("Sheet1")
With Sheets("Sheet2")
lr = .Cells.Find(what:=Chr(42), after:=.Cells(1, 1), SearchDirection:=xlPrevious).Row
For rw = 1 To lr
If CBool(Application.CountA(Rows(rw))) Then
vVALs = .Cells(rw, 1).Resize(1, .Cells(rw, Columns.Count).End(xlToLeft).Column).Value
sVALs = ChrW(8203) & Join(Application.Index(vVALs, 1, 0), ChrW(8203)) & ChrW(8203)
Do While CBool(InStr(1, sVALs, ChrW(8203) & ChrW(8203)))
sVALs = Replace(sVALs, ChrW(8203) & ChrW(8203), ChrW(8203))
Loop
sVALs = Mid(sVALs, 2, Len(sVALs) - 2)
vVALs = Split(sVALs, ChrW(8203))
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(vVALs) + 1) = vVALs
End If
Next rw
'Debug.Print lr
End With
End Sub
I've used a zero-length space as the delimiter as it is usually unlikely to be a part of a user's data.
You can try below approach also...
Public Sub remove_blank()
Dim arrayValue() As Variant
ThisWorkbook.Sheets("Sheet1").Activate ' Sheet1 has the data with blanks
arrayValue = range("A1:H2") ' Range where the data present...
Dim i As Long
Dim j As Long
Dim x As Integer: x = 1
Dim y As Integer: y = 1
For i = 1 To UBound(arrayValue, 1)
For j = 1 To UBound(arrayValue, 2)
Dim sStr As String: sStr = arrayValue(i, j)
If (Len(Trim(sStr)) <> 0) Then
ThisWorkbook.Sheets("Sheet2").Cells(x, y).Value = sStr ' Sheet2 is the destination
y = y + 1
End If
Next j
x = x + 1
y = 1
Next i
End Sub
I am searching for a column in vba that has a certain header and then when I find that I want to search all the rows in that column and replace all the X's with 1's. I have all the code written but for some reason its not allowing the line shown below:
r2 = Range(i, i).EntireColumn.Rows.Count
Sub PA_Change()
Dim i As Long, r As Range, rRow As Range, r2 As Long
Set r = Range("A1")
Set rRow = r.EntireRow
For i = 1 To rRow.Columns.Count
If Cells(1, i) = PA_REQUIRED Then
r2 = Range(i, i).EntireColumn.Rows.Count
For j = 1 To r2
If Cells(j, i).Value = "X" Then
Cells(j, i).Value = "1"
End If
Next j
End If
Next i
End Sub
Try replacing all your code with this and let us know if that works:
*replace the "boo" in searchFor with the actual header name / PA_REQUIRED
Sub PA_Change()
Dim searchFor As String
searchFor = "boo"
Dim grabColumn As Range
Set grabColumn = Rows("1:1").Find(What:=searchFor, _
After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False)
If Not grabColumn Is Nothing Then
Dim entireColumn As Range
Set entireColumn = Range(grabColumn.Address & ":" & Split(grabColumn.Address, "$")(1) & Range(Split(grabColumn.Address, "$")(1) & Rows.Count).End(xlUp).Row)
Dim cell As Range
For Each cell In entireColumn
If UCase(cell) = "X" Then
cell = "1"
End If
Next
Else
Exit Sub ' not found
End If
End Sub
Sub CHECKas()
Dim lastrow As Long
Dim lastcol As Long
Dim l As Integer
Dim i As Integer
Dim rname As Constants
Set rngTarg = Selection
lastrow = Sheets("report").Range("B" & Rows.Count).End(xlUp).row
lastcol = Sheets("report").Cells(2, Columns.Count).End(xlToLeft).Column
Sheets("FEBBRAIO").Select
ActiveCell.Offset(0, -3).Copy
Sheets("REPORT").Select
Cells(1, lastcol + 1).PasteSpecial xlPasteAll
Application.CutCopyMode = False
rname = Application.ActiveCell.Value
ActiveCell.Offset(1, 0).Select
For i = 2 To lastrow
ThisWorkbook.Sheets("report").Select
If Range("f2:f" & lastrow) <= Val(CStr(rname.Value)) _
And Range("g2:g" & lastrow) > Val(CStr(rname.Value)) Then
Cells(i, ActiveCell.Column).Value = "1"
Else
Cells(i, ActiveCell.Column).Value = 0
End If
Next i
End Sub
I'm new in VBA and I can't understand how to compare a constant value with each cell in a range("g2:g" & lastrow) and ("f2:f" & lastrow). The constant value is an active cell in my case. For example considering this formula: IF(AND($R$1<G2;$R$1>=f2);1;0 where R$1$ is the active cell of the last not empty column in ROW 1. I need to fill the entire column (that is activecell.column) with the output coming out form this formula.
But the I Got mismatch error in:
If Range("f2:f" & lastrow) <= Val(CStr(rname.Value)) _
And Range("g2:g" & lastrow) > Val(CStr(rname.Value)) Then
Cells(i, ActiveCell.Column).Value = "1"
Else
Cells(i, ActiveCell.Column).Value = 0
End If
I know from the previous question that this error occurs because I'm trying to comparing a single value against an array of values. How can fix this problem?
You have to use
Range("F" & i)
in your code. Same thing applies to other instances of such code.
Need some help with the following:
I have several worksheets with the same structure and within each worksheet I have two columns (let's call them X & Y) that I need to copy with their cellvalues (letter-number combination) and also copy the values of Column A-F to an own sheet for X and Y.
On the "new" sheet I want to put X/Y to column A sort the values after A and attach a constant hyperlink to each cellvalue in A.
So X or Y goes to A and A-F to B-G.
Then I want to make column F or the new G clickable so that it will take me to the row in the according worksheet.
X and Y don't always happen to be in column X or Y but I think this can be solved with a "name search".
When I execute my code then for example worksheet3 will overwrite the values of worksheet1 and my hyperlink structure is wrong too. The sorting is left out since that is working.
Function CopyAndSort(ByRef mySheet As Worksheet)
' If mySheet.Name <> "Sheet1" Then
' Exit Function
' End If
mySheet.Activate
Set sheetCS = Sheets("CopyAndSort Sheet")
sheetCS.Range("A:A").Value = ""
lastRowCS = Range("X:X").Cells.Find("*", , , , , xlPrevious).Row
rowNumber = 1
For rowCopy = 5 To lastRowFO
sheetCopy = Range("BE" & rowCopy)
If Trim(sheetCopy) <> "" Then
sheetCopy = Replace(sheetCopy, """", "")
If InStr(1, sheetCopy, ",", vbTextCompare) <> 0 Then
sheetCopyArray = Split(sheetCopy, ",")
Else
sheetCopyArray = Array(sheetCopy)
End If
For Each copy In sheetCopyArray
rowNumber = rowNumber + 1
copy_Value = copy
' test for url
' sheetCS.Cells(rowNumber, 1).Formula = "=HYPERLINK(""ConstURL & copyValue"")"
sheetCS.Cells(rowNumber, 1) = copy_Value
copy_Value = Cells(rowCopy, 1)
sheetCS.Cells(rowNumber, 2) = copy_Value
copy_Value = Cells(rowCopy, 2)
sheetCS.Cells(rowNumber, 3) = copy_Value
copy_Value = Cells(rowCopy, 3)
sheetCS.Cells(rowNumber, 4) = copy_Value
copy_Value = Cells(rowCopy, 4)
sheetCS.Cells(rowNumber, 5) = copy_Value
copy_Value = Cells(rowCopy, 5)
sheetCS.Cells(rowNumber, 6) = copy_Value
Next
End If
Next
So how can I manage to not overwrite the values and attach the correct hyperlink syntax, plus making colum G clickable?
And can I use one function for X and Y?
Some code examples would help me alot.
Thank you.
UPDATE:
i forgot to mention that X & Y will always be next to each other.
Example:
Sheet1:
|ColA|ColB|ColC|ColD|ColF|....|ColX|ColY|
Sheet2: here "ColX" is in ColQ and ColY in ColR
|ColA|ColB|ColC|ColD|ColF|....|ColXinColQ|ColYinColR|
CopySheet_of_X: now copy ColX plus ColA-ColF of Sheet1 and do the same for Sheet2 where X is in ColQ
Output for both sheets:
|ColX|ColA|ColB|ColC|ColD|ColF|
CopySheet_of_Y: now copy ColY plus ColA-ColF of Sheet1 and do the same for Sheet2 where Y is in ColR
Output for both sheets:
|ColY|ColA|ColB|ColC|ColD|ColF|
Hyperlink:
so now the values of ColX and ColY should be concatenated with a preceding hyperlink:
If a cell in ColX has the value of "someValue1" then it should be turned into myurl://sometext=someValue1
and I don't know the right way to jump back to the row when clicking on ColF.
Try this. Paste this in a module and run Sub Sample.
Option Explicit
Const hLink As String = "d3://d3explorer/idlist="
Sub Sample()
Dim sheetsToProcess
Set sheetsToProcess = Sheets(Array("Sheet1", "Sheet2"))
CopyData sheetsToProcess, "CopySheet_of_X", "FirstLinkValue"
'~~> Similarly for Y
'CopyData sheetsToProcess, "CopySheet_of_Y", "SecondLinkValue"
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' USAGE '
' wsI : Worksheet Collection '
' wsONm : name of the new sheet for output '
' XY : Name of the X or Y Header '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Sub CopyData(wsI, wsONm As String, XY As String)
Dim ws As Worksheet, sSheet As Worksheet
Dim aCell As Range
Dim lRow As Long, LastRow As Long, lCol As Long, i As Long, j As Long
Dim MyAr() As String
'~~> Delete the Output sheet if it is already there
On Error Resume Next
Application.DisplayAlerts = False
Sheets(wsONm).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'~~> Recreate the output sheet
Set ws = Sheets.Add: ws.Name = wsONm
'~~> Create Headers in Output Sheet
ws.Range("A1") = XY
wsI(1).Range("A3:F3").Copy ws.Range("B1")
'~~> Loop throught the sheets array
For Each sSheet In wsI
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 1
With Sheets(sSheet.Name)
'~~> Find the column which has X/Y header
Set aCell = .Rows(3).Find(What:=XY, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If aCell Is Nothing Then
'~~> If not found, inform and exit
MsgBox XY & " was not found in " & .Name, vbCritical, "Exiting Application"
Exit Sub
Else
'~~> if found then get the column number
lCol = aCell.Column
'~~> Identify the last row of the sheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the X Column and split values
For i = 4 To lRow
If InStr(1, .Cells(i, lCol), ",") Then '<~~ If values like A1,A2,A3
MyAr = Split(.Cells(i, lCol), ",")
For j = 0 To UBound(MyAr)
'~~> Add hyperlink in Col 1
With ws
.Cells(LastRow, 1).Value = MyAr(j)
.Hyperlinks.Add Anchor:=.Cells(LastRow, 1), Address:= _
hLink & .Cells(LastRow, 1).Value, TextToDisplay:=.Cells(LastRow, 1).Value
End With
.Range("A" & i & ":F" & i).Copy ws.Range("B" & LastRow)
'~~> Add hyperlink in Col 2
With ws
.Hyperlinks.Add Anchor:=.Cells(LastRow, 7), Address:="", SubAddress:= _
sSheet.Name & "!" & "A" & i, TextToDisplay:=.Cells(LastRow, 7).Value
End With
LastRow = LastRow + 1
Next j
Else '<~~ If values like A1
'~~> Add hyperlink in Col 1
With ws
.Cells(LastRow, 1).Value = Sheets(sSheet.Name).Cells(i, lCol)
.Hyperlinks.Add Anchor:=.Cells(LastRow, 1), Address:= _
hLink & .Cells(LastRow, 1).Value, TextToDisplay:=.Cells(LastRow, 1).Value
End With
.Range("A" & i & ":F" & i).Copy ws.Range("B" & LastRow)
'~~> Add hyperlink in Col 2
With ws
.Hyperlinks.Add Anchor:=.Cells(LastRow, 7), Address:="", SubAddress:= _
sSheet.Name & "!" & "A" & i, TextToDisplay:=.Cells(LastRow, 7).Value
End With
LastRow = LastRow + 1
End If
Next i
End If
End With
Next
'~~> Sort the data
ws.Columns("A:G").Sort Key1:=ws.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End Sub