I have wrote a programm to replace special character in cell with normal character(alphabets)
I have written comments for each block in my programm.
However before executing all rows, after second row it goes to next column
Sub special_char_Replace()
Dim h As String
Dim m, clm, rw As Integer
Dim colspc As New Collection
Dim valspc As New Collection
'Below part makes collection of special character and its replacement values
On Error Resume Next
ThisWorkbook.Worksheets("Sheet2").Activate
m = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To m
colspc.Add Cells(i, 1)
valspc.Add Cells(i, 2)
Next
'Activate destination workbook from which special characters to be replaced
Workbooks("common file.xlsx").Worksheets("Sheet1").Activate
LR = Cells(Rows.Count, "E").End(xlUp).Row
'Below loop replaces special characters and inserts original value at 5th 'column aside
For clm = 5 To 6
For rw = 2 To LR
For i = 1 To m
On Error Resume Next
h = Range(Cells(rw, clm), Cells(rw, clm)).Find(What:=colspc(i), after:=Range(Cells(rw, clm), Cells(rw, clm)), LookIn:=xlFormulas, Lookat:=xlPart).Address
If h <> "" Then
Range(h).Offset(0, 5) = Range(h).Value
Range(Cells(rw, clm), Cells(rw, clm)).Replace What:=colspc(i), replacement:=valspc(i), Lookat:=xlPart, searchorder:=xlByColumns, MatchCase:=False
End If
h = ""
Next i
Next rw
Next clm
End Sub
Thanks for everyone's support
I made changes, instead of find function, I have defined two dimentional string cellval(I,J)
First I will save all cell values in this string with for loop
cellval(I, j) = Cells(I, j).Value
After execution of replace command, below lines will check all string values with result
if there is changes it will relfect in output sheet
If cellval(I, j) <> Sheets(ws.Name).Cells(I, j).Value Then
Cells(I, j).Value = cellval(I, j)
Related
I tried to run the the script but once it reached blank cell the macro just stopped.
I also tried input some text on each blank cell but "For loop not initialized" appear.
Please see the code I used down below:
Sub test()
Dim lastrow As Integer
Dim i As Integer
Dim descriptions() As String
With Worksheets("Sheet1")
lastrow = .Range("O3").End(xlDown).Row
For i = lastrow To 3 Step -1
If InStr(1, .Range("O" & i).Value, ",") \<\> 0 Then
descriptions = Split(.Range("O" & i).Value, ",")
End If
For Each Item In descriptions
.Range("O" & i).Value = Item
.Rows(i).Copy
.Rows(i).Insert
Next Item
.Rows(i).EntireRow.Delete
Next i
End With
End Sub
Thank you in advanced.
I expected for the script to run through and insert row if cell have commas.
Insert Split Cell Values
Instead of .Rows(r).Insert, you should consider using .Cells(r, "O").Insert for the rest of the columns not to be affected.
On the other hand, if you have data in the other columns that need to be copied, in the middle of the inner loop, slip in the line .Rows(r).Copy.
Option Explicit
Sub SplitDescriptions()
With ThisWorkbook.Sheets("Sheet1")
Dim Descriptions() As String, dUpper As Long, d As Long
Dim r As Long, rString As String
For r = .Cells(.Rows.Count, "O").End(xlUp).Row To 3 Step -1
rString = CStr(.Cells(r, "O").Value)
If InStr(rString, ",") > 0 Then
Descriptions = Split(rString, ",")
dUpper = UBound(Descriptions)
For d = 0 To dUpper
.Cells(r, "O").Value = Descriptions(d)
If d < dUpper Then .Rows(r).Insert
Next d
End If
Next r
End With
End Sub
To get the order left-to-right as top-to-bottom, replace the inner loop with the following.
For d = dUpper To 0 Step -1
.Cells(r, "O").Value = Descriptions(d)
If d > 0 Then .Rows(r).Insert
Next d
I am trying to make a loop that prints every value between two cells in a row into a single column. I would also like it to skip/ignore non integer values.
For example: Cell A5 contains 5673 and Cell B5 contains 5677. Therefore the macro would output 5673, 5674, 5675, 5676, and 5677.
I have found some useful examples for looping through each row and printing each value, but have not been able to combine the two.
To print each value between the two numbers:
[D1] = [A1].Value
ato = [B1].Value
[D1].DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=ato
To loop through every row:
LR = Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To LR
Cells(j, 1).Offset(0, 2).Value = ***Every cell value between Cells(j, 1) and Cells(j, 2)***
Next j
Before:
Desired after:
Try this. You can use SpecialCells to pick out the numerical cells, and Fill to produce the intervening sequences.
Sub x()
Dim rA As Range, rCell As Range
For Each rA In Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers).Areas
For Each rCell In rA
Range("D" & Rows.Count).End(xlUp)(2).Value = rCell.Value
Range("D" & Rows.Count).End(xlUp).DataSeries Rowcol:=xlColumns, Step:=1, Stop:=rCell.Offset(, 1), Trend:=False
Next rCell
Next rA
End Sub
If you will always have these 2 columns, then you may use this code
for j = 1 to 2:for i = 1 to cells(rows.count,j).end(xlup).row
if isnumeric(cells(i,j)) then cells(rows.count,4).end(xlup).offset(1,0) = cells(i,j)
next:next
bear in mind that it will post everysingle number, if you need to delete duplicates, you may do it using range.removeduplicate
Loop through the range cell by cell; test for IsNumeric and Duplicate values. Note: this is just a test code, you should always add workbook and worksheet references
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 2
If IsNumeric(Cells(i, j)) And Cells(i, j).Offset(, 1).Value <> Cells(i, j).Value Then
If IsEmpty(Cells(1, 4).Value) Then
Cells(1, 4) = Cells(i, j)
Else: Cells(Rows.Count, 4).End(xlUp).Offset(1) = Cells(i, j)
End If
End If
Next j
Next i
I have a fairly simple For loop that is looking at 2 columns - NAME and JOB. If there are comma delimited names in a cell, it triggers a function that inserts each name one row below, and then takes the number of new rows and adds it to the last row value (minus 1). Then, if there is no JOB next to that name, it uses the JOB value +1 above.
Problem I am running into is that even though I can see that the LastRow value is being added to as I step through, the loop still exits after it reaches the original LastRow value when the loop began.
i.e. if LR = 100 at the beginning of the loop, but because of CountUnique, LR now = 115, the loop still exits after 100.
I cannot figure out why.
LR = Range("B" & Rows.Count).End(xlUp).Row
' Mirror missing attributes
For i = 2 To LR
If InStr(Cells(i, 2).Value, ",") Then
LR = LR + CountUnique(Cells(i, 2)) - 1
End If
If Cells(i, 1).Value = "" Then
Cells(i, 1).Value = Cells(i - 1, 1).Value
End If
Next i
Public Function CountUnique(r As Range) As Integer
Dim c As Collection
Set c = New Collection
ary = Split(r.Text, ",")
On Error Resume Next
For Each a In ary
c.Add a, CStr(a)
If Err.Number = 0 Then
If CountUnique >= 1 Then
r.Offset(CountUnique, 0).EntireRow.Insert
r.Offset(CountUnique, 0).Value = Trim(a)
End If
CountUnique = CountUnique + 1
Else
Err.Number = 0
End If
Next a
r.Value = c.Item(1)
End Function
In VB, the boundaries of the For loop are evaluated once at the start and the values are cached.
If you want a dynamic upper bound, you need to use a Do loop.
I will be in receipt of a weekly file in which a column must be Split using a "," delimiter, but in which the position of the target column and the length of the values in that column are unknown, and will vary.
Some of the values in the target column for the Split have leading 0's , which are currently being removed as you would expect if the characters were input to a column formatted as General. The target column for the Split is always formatted as Text prior to executing the Split. All values from columns other than the targeted column must be retained.
The target column appears to be converted to General instead of the intended Text format after the below procedure is run. I'm uncertain as to how to ensure the column remains Text and the leading 0's are preserved.
Current Sub:
Sub Test_Split_Column()
Dim LR As Long, i As Long, LC As Integer
Dim x As Variant
Dim r As Range, iCol As Integer
On Error Resume Next
Set r = Application.InputBox("Click in the column to split by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
On Error Resume Next
ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Value = " "
On Error GoTo 0
iCol = r.Column
Application.ScreenUpdating = False
LC = Cells(1, Columns.Count).End(xlToLeft).Column
LR = Cells(Rows.Count, iCol).End(xlUp).Row
Columns(iCol).Insert
For i = LR To 1 Step -1
With Cells(i, iCol + 1)
If InStr(.Value, ",") = 0 Then
.Offset(, -1).Value = .Value
Else
x = Split(.Value, ",")
.Offset(1).Resize(UBound(x)).EntireRow.Insert
.Offset(, -1).Resize(UBound(x) - LBound(x) + 1).Value = Application.Transpose(x)
End If
End With
Next i
Columns(iCol + 1).Delete
LR = Cells(Rows.Count, iCol).End(xlUp).Row
With Range(Cells(1, 1), Cells(LR, LC))
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
With ActiveSheet.UsedRange
.Replace What:=" ", Replacement:=vbNullString, LookAt:=xlWhole
End With
Application.ScreenUpdating = True
End Sub
Examples of Raw Data, Current Output, and Desired Output linked below:
Examples
Any assistance you can provide is greatly appreciated! Thanks!
' can be used to force excel to treat any value as text.
x = Split(Replace("'" & .Value, ",", ",'"), ",")
If you assign a String array instead of a Variant array to a range, the values will be set as Strings even if the values are numeric.
Something like this should work.
Dim strValue As String
strValue = "000123,1234,0001"
Dim x As Variant
x = Split(strValue, ",")
ReDim result(0 To UBound(x), 0 To 0) As String
Dim i As Integer
For i = 0 To UBound(x)
result(i, 0) = x(i)
Next i
ActiveSheet.Range("A1:A3").Value = result
I am not sure if the title is correct. Please correct me if you have a better idea.
Here is my problem: Please see the picture.
This excel sheet contains only one column, let's say ColumnA. In ColumnA there are some cells repeat themselvs in the continued cells twice or three times (or even more).
I want to have the excel sheet transformed according to those repeated cells. For those items which repeat three times or more, keep only two of them.
[Shown in the right part of the picture. There are three Bs originally, target is just keep two Bs and delete the rest Bs.]
It's a very difficult task for me. To make it easier, it's no need to delete the empty rows after transformation.
Any kind of help will be highly appreciated. Thanks!
#
Update:
Please see the picture. Please dont delete the items if they show again...
EDITED - SEE BELOW Try this. Data is assumed to be in "Sheet1", and ordered data is written to "Results". I named your repeted data (A, B, C, etc) as sMarker, and values in between as sInsideTheMarker. If markers are not consecutive, the code will fail.
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 2
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = k + 1
a = 2
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, 1).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
EDITION: If you want results in the same sheet ("Sheet1"), and keep the empty rows for results to look exactly as your question, try the following
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 5
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = i
a = 5
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, 4).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
If you can delete the values that have more than two counts, then I suggest that this might work:
Sub count_macro()
Dim a As Integer
Dim b As Integer
a = 1
While Cells(a, 1) <> ""
b = WorksheetFunction.CountIf(Range("A1:A1000"), Cells(a, 1))
If b > 2 Then
Cells(a, 1).Delete Shift:=xlUp
End If
b = 0
a = a + 1
Wend
End Sub
This should do it. It takes input in column A starting in Row 2 until it ends, and ignores more than 2 same consecutive values. Then it copies them in sets and pastes them transposed. If your data is in a different column and row, change the sourceRange variable and the i variable accordingly.
Sub SETranspose()
Application.ScreenUpdating = False
Dim sourceRange As range
Dim copyRange As range
Dim myCell As range
Set sourceRange = range("A2", Cells(Rows.count, 1).End(xlUp))
Dim startCell As range
Set startCell = sourceRange(1, 1)
Dim i As Integer
Dim haveTwo As Boolean
haveTwo = True
For i = 3 To Cells(Rows.count, 1).End(xlUp).Row + 1
If Cells(i, 1).Value = startCell.Value Then
If haveTwo Then
range(startCell, Cells(i, 1)).Copy
startCell.Offset(0, 4).PasteSpecial Transpose:=True
Application.CutCopyMode = False
haveTwo = False
End If
End If
'if the letter changes or end of set, then copy the set over
'If LCase(Left(Cells(i, 1).Value, 1)) <> LCase(startCell.Value) Or _
'i = Cells(Rows.count, 1).End(xlUp).Row + 1 Then
If Len(Cells(i, 1).Value) > 1 Then
Set copyRange = Cells(i, 1)
copyRange.Copy
Cells(startCell.Row, Columns.count).End(xlToLeft).Offset(0, 1).PasteSpecial
Application.CutCopyMode = False
'Set startCell = sourceRange(i - 1, 1)
ElseIf Len(Cells(i, 1).Value) = 1 And Cells(i, 1).Value <> startCell.Value Then
Set startCell = sourceRange(i - 1, 1)
haveTwo = True
End If
Next i
'clear up data
Set sourceRange = Nothing
Set copyRange = Nothing
Set startCell = Nothing
Application.ScreenUpdating = True
End Sub