I have an issue with the REPLACE function of VBA.
For example, whem I'm in a sheet and use CTRL + H to replace all the "." to ",", it works good.
But when I'm trying to do it with a macro I have an issue with the values > than 1
0.8 ---> 0,8
0.9 ---> 0,9
1.09978063783 ---> 109978063783
Here is the code :
Rows("10:10").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, MatchByte:=False
Would this do the trick for you?
Sub Test()
Dim i As Integer, rng As Range, cell As Range
For i = 10 To 1000
Set rng = Rows(i)
rng.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, MatchByte:=False
Next i
End Sub
Try this code:
Sub DotsToCommas()
Dim Txt As String, Col As Long
For Col = 1 To ActiveSheet.Columns.Count
Txt = CStr(ActiveSheet.Cells(10, Col).Value)
If Txt = "" Then
Exit Sub
End If
Txt = Replace(Txt, ".", ",")
ActiveSheet.Cells(10, Col).Value = Txt
Next
End Sub
It will take a bit more time, as it does a loop through all cells until it finds a empty one.
This should do it:
Sub replaceDecimalPoint()
Dim lastRowNum As Long
Dim lastColNum As Long
Dim startRow As Long
Dim tempVal As String
lastRowNum = Cells(Rows.Count, 1).End(xlUp).Row
lastColNum = Cells(10, Columns.Count).End(xlToLeft).Column
startRow = 10 'Change this if row start number is required to be changed from 10
Dim rangeArray As Variant
rangeArray = Range(Cells(startRow, 1), Cells(lastRowNum, lastColNum)).Value 'Assuming to start at row 10 as you have used Row 10 (And Column A) - If NOT, Change startRow
For r = startRow To lastRowNum 'Assuming to start at row 10 as you have used Row 10 - If NOT, Change startRow
For c = 1 To lastColNum
tempVal = rangeArray(r - (startRow - 1), c)
If CDbl(tempVal) > 1 Then
tempVal = CStr((tempVal * (10 ^ (Len(tempVal) - 1))))
End If
rangeArray(r - (startRow - 1), c) = Replace(CStr(tempVal), ".", ",")
Next c
Next r
Range(Cells(startRow, 1), Cells(lastRowNum, lastColNum)).Value = rangeArray
End Sub
Related
I have a excel sheet containing multiple cells with a string foo in the first row. I want to find the first and last column in which the string is written. I have tried the following
Dim first_col As Integer
Dim last_col As Integer
Dim col As Integer
Dim found As Range
Dim ws_MLB as Worksheet
Dim foo as String
set ws_MLB = ThisWorkbook.Sheet(1)
Set found = ws_MLB.Rows(1).Find(foo)
If Not found Is Nothing Then
col = found.Column
first_col = col
last_col = col
Do
found = ws_MLB.Rows(1).FindNext(found)
col = found.Column
If col < first_col Then
first_col = col
MsgBox ("This should not happen")
ElseIf col > last_col Then
last_col = col
End If
Loop While Not found Is Nothing And col <> first_col
Else
MsgBox ("not found")
End If
But this way I only get the the first value for both first_col and last_col. When I search for the string with the integrated excel search I find multiple instances. So the string is there. Have I done a mistake or is there a better way to do this?
edit forgot to mention that I also tried to change the search direction, but I still got the first entry.
You can make this a lot easier by using the SearchDirection Parameter in .Find by using xlNext you search Left to Right then xlPrevious searches Right to Left.
Sub FindFL()
Dim wbk As Workbook
Dim ws As Worksheet
Dim fColumn As Long, lColumn As Long
Set wbk = ThisWorkbook 'Change this to your workbook
Set ws = wbk.Worksheets("Sheet1") 'Change this to your worksheet
With ws
'Find first column that foo shows up
fColumn = .Cells.Find(What:="foo", _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False).Column
'Find last column that foo shows up
lColumn = .Cells.Find(What:="foo", _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Debug.Print "First Column is " & fColumn; vbNewLine _
; "Last Column is " & lColumn
End With
End Sub
I would do that like this:
Public Sub foo()
Dim nCol As Integer
Dim nFirst As Integer
Dim nLast As Integer
With ActiveSheet
nCol = 1
Do Until .Cells(1, nCol) = ""
If .Cells(1, nCol) = "foo" Then
If nFirst = 0 Then
nFirst = nCol
Else
nLast = nCol
End If
End If
nCol = nCol + 1
Loop
End With
MsgBox "First: " & nFirst & vbCr & "Last: " & nLast
End Sub
some time ago I posted a similar question here and got a great answer. But now I would need a slightly altered code but I am not able to change it up.
In an Excel sheet I have cells which have values but all cells between those two are empty. I want Excel to fill the empty cells between them with the values of a third cell. To visualise:
That's what it looks like
Now I want the macro to fill out all the empty cells with the value of the corresponding J cell. So it would look like this:
From the previous thread I used this code:
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1), .Areas(2)).Value = .Areas(1).Value
End With
Next
End Sub
Is it possible to change up the existing code? Or maybe the other code from my previous, linked question? I looked into both but I myself unfortunately wasn't able.
Any help is appreciated. Thanks in advance.
Use the code from the your other question but change rowval to look at column J
Option Explicit
Sub test_DTodor()
Dim wS As Worksheet
Dim LastRow As Double
Dim LastCol As Double
Dim i As Double
Dim j As Double
Dim k As Double
Dim RowVal As String
Set wS = ThisWorkbook.Sheets("Sheet1")
LastRow = LastRow_1(wS)
LastCol = LastCol_1(wS)
For i = 1 To LastRow
For j = 1 To LastCol
With wS
If .Cells(i, j) <> vbNullString Then
'1st value of the row found
RowVal = .Cells(i, 10).Value --This is all I changed
k = 1
'Fill until next value of that row
Do While j + k <= LastCol And .Cells(i, j + k) = vbNullString
.Cells(i, j + k).Value = RowVal
k = k + 1
Loop
'Go to next row
Exit For
Else
End If
End With 'wS
Next j
Next i
End Sub
Public Function LastCol_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastCol_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Else
LastCol_1 = 1
End If
End With
End Function
Public Function LastRow_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow_1 = 1
End If
End With
End Function
Answer with modifying previous code
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1).Offset(, 1), .Areas(2).Offset(, -1)).Value = Cells(.Areas(1).Row, "J").Value
End With
Next
End Sub
Assuming you have three values in each row and they are not consecutive, a small change to your original code should suffice.
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1).Offset(, 1), .Areas(2).Offset(, -1)).Value = .Areas(3).Value
End With
Next
End Sub
This will do exactly what you want in three lines
Sub FillBlanks()
Dim c
For Each c In ActiveSheet.UsedRange.Columns("J").SpecialCells(xlCellTypeConstants)
Range(c.Offset(0, c.End(xlToLeft).Column - c.Column), c.Offset(0, -c.Column + 1)).SpecialCells(xlCellTypeBlanks).Value2 = c.Value2
Next c
End Sub
I am currently trying to write some VBA code which will fill out all cells between two cells with the value of the two cells.
Here is what I have :
And I would like the code to fill out all cells in between like this:
So, as you can see I would like all the cells in between to be filled out with the same value as the two corner cells.
Any help is very much appreciated! Thanks in advance.
you could use SpecialCells() method of Range object:
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1), .Areas(2)).Value = .Areas(1).Value
End With
Next
End Sub
Place this in a new module and run test_DTodor:
Option Explicit
Sub test_DTodor()
Dim wS As Worksheet
Dim LastRow As Double
Dim LastCol As Double
Dim i As Double
Dim j As Double
Dim k As Double
Dim RowVal As String
Set wS = ThisWorkbook.Sheets("Sheet1")
LastRow = LastRow_1(wS)
LastCol = LastCol_1(wS)
For i = 1 To LastRow
For j = 1 To LastCol
With wS
If .Cells(i, j) <> vbNullString Then
'1st value of the row found
RowVal = .Cells(i, j).Value
k = 1
'Fill until next value of that row
Do While j + k <= LastCol And .Cells(i, j + k) = vbNullString
.Cells(i, j + k).Value = RowVal
k = k + 1
Loop
'Go to next row
Exit For
Else
End If
End With 'wS
Next j
Next i
End Sub
Public Function LastCol_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastCol_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Else
LastCol_1 = 1
End If
End With
End Function
Public Function LastRow_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow_1 = 1
End If
End With
End Function
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