I found this script on here and modified it some to fit my needs. However, I cannot figure out how to insert one cell instead of the entire row
Sub BlankLine()
Dim Col As Variant
Dim Col2 As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "A"
Col2 = "B"
StartRow = 2
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) <> .Cells(R, Col2) Then
.Cells(R, Col2).EntireRow.Insert Shift:=xlUp
End If
Next R
End With Application.ScreenUpdating = True
End Sub
So, if column A does not match Column B at any given row insert a space then keep going with the compare adding one row above any false value.
Example: 1 1
2 3
3 4
Becomes: 1 1
2
3 3
4
Any help would be greatly appreciated!
.Cells(R, Col2).Insert Shift:=xlDown
You will need to change your loop from:
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) <> .Cells(R, Col2) Then
.Cells(R, Col2).EntireRow.Insert Shift:=xlUp
End If
Next R
to
For R = StartRow To LastRow
If .Cells(R, Col).Value <> .Cells(R, Col2).Value Then
.Cells(R, Col2).Insert Shift:=xlDown
End If
Next R
A word of warning - if you data looks like this:
Example: 1 3
2 1
3 2
it will end up looking like this:
Becomes: 1
2
3 3
1
2
so make sure your data is in a sensible sequence before using this.
Related
I'm trying to remove all rows form a Range that have a cell with value "Totals" in them. I tried something like this:
For Each cell In rng
If CStr(cell.Value) = "Totals" Then
cell.EntireRow.Delete
End If
Next cell
The problem is that whenever there are two rows both containing a cell with "Totals" only the first row gets removed. How can I solve that?
You'll need a pattern like this:
Dim numberOfRows as Integer, rw as Integer, col as Integer
numberOfRows = 100 // You probably want to set this using your `rng` object
col = 1 // column 'A' (but set for your situation)
For rw = numberOfRows to 1 Step -1
If CStr(Cells(rw, col)) = "Totals" Then
Cells(rw, col).EntireRow.Delete
End If
Next rw
EDIT Two alternative methods
Suppose I have data in A1:C3 as follows:
A B C
1 1 2 3
2 4 Totals 5
3 6 7 8
I want to delete any rows containing Totals. Here are two ways to do it:
Sub MarkToDelete()
Dim rng As Range, cl As Range, rw As Integer
Set rng = Range("A1:C3")
For Each cl In rng
If cl = "Totals" Then
Cells(cl.Row, 4) = "DELETE" //i.e. in column D add a note to delete
End If
Next cl
For rw = rng.Rows.Count To 1 Step -1
If Cells(rw, 4) = "DELETE" Then
Cells(rw, 4).EntireRow.Delete
End If
Next rw
End Sub
Sub LoopRemove()
Dim rw As Integer, col As Integer
Set rng = Range("A1:C3")
For rw = rng.Rows.Count To 1 Step -1
For col = 1 To rng.Columns.Count
If Cells(rw, col) = "Totals" Then
Cells(rw, col).EntireRow.Delete
End If
Next col
Next rw
End Sub
I wanted to add a row in excel vba when ever the value in column A is 1, here is the code I wrote, but this returns a "subscript out of range error". What am I doing wrong?
Sub InsertRow()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Application.ScreenUpdating = False
Col = "A"
StartRow = 1
LastRow = 20
Worksheets("Sheet1").Activate
For R = StartRow To LastRow
If Cells(R, Col) = 1 Then
Cells(R, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
Application.ScreenUpdating = True
End Sub
Code below tested and works.
With Worksheets("Sheet1")
Dim cntr as Long
For cntr = 20 to 5 Step - 1
If .Cells(cntr, 1) = 1 Then .cells(cntr,1).EntireRow.Insert Shift:=xlDown
Next
End With
Sub InsertRow()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Application.ScreenUpdating = False
Col = "A"
StartRow = 1
LastRow = 20
Worksheets("Sheet1").Activate
R = StartRow
Do While R <= LastRow
If Cells(R, Col) = 1 Then
Cells(R, Col).EntireRow.Insert Shift:=xlDown
R = R + 1
LastRow = LastRow + 1
End If
R = R + 1
Loop
Application.ScreenUpdating = True
End Sub
Note the setting of the value of R in the loop, as you are shifting the rows down, you are continually checking the same value and therefore adding a row each time so we need to increment R by 1 to skip past the 1 we just checked.
We also need to change the endpoint as we are pushing values past Row 20 by inserting so we also increment the LastRow variable. We cannot do this in a for loop in VBA, the for loop will terminate at 20 so I have changed to a while loop
As per the comment below, working backwards from 20 is far more elequent but since I didn't think of that I haven't put it in here :)
I am trying to offset two columns of data to a row at a specific order, but I am not being able to set the offset function properly.
I have something like:
ColumnA ColumnB
1 10
2 20
3 30
4 40
5 50
And I am trying to get 1 row, multiple columns, starting in a given ActiveCell that I may select (1 10 2 20 3 30 4 40 5 50)
My code so far is:
Sub OffsetData1()
Dim lRow As Long
lRow = 0
Do
lRow = lRow + 1
If IsEmpty(Cells(lRow, 2)) Then Exit Do
Cells(lRow, 2).Copy
ActiveCell.Offset(1, 1).PasteSpecial
Loop
End Sub
Any help would be deeply appreciated.
Try the code below (explanations are inside the code comments)
Option Explicit
Sub OffsetData1()
Dim lRow As Long, Col As Integer
Dim RowDest As Long, ColDest As Integer
' parameters for first cell Paste, these setting are for Cell A7
RowDest = 7
ColDest = 1
For lRow = 1 To 5 ' loop through rows
For Col = 1 To 2 ' loop through columns
' only copy cells with values inside
If Cells(lRow, Col) <> "" Then
Cells(RowDest, ColDest) = Cells(lRow, Col)
ColDest = ColDest + 1
End If
Next Col
Next lRow
End Sub
you can exploit the "natural" enumeration of a range:
Option Explicit
Sub main2()
Dim cell As Range
Dim iCol As Long
For Each cell In Range("B1", Cells(Rows.Count, "A").End(xlUp))
iCol = iCol + 1
Cells(7, iCol) = cell.Value
Next
End Sub
I have an excel table that has some duplicates and we currently have a count of these however I want to populate a unique number for each duplicate. e.g.
Number Count Sequence
1 2 1
1 2 1
2 3 2
2 3 2
2 3 2
3 4 3
3 4 3
3 4 3
3 4 3
4 2 4
4 2 4
5 5 5
5 5 5
5 5 5
5 5 5
5 5 5
I was playing with the following IF statement but I want it to check through the whole range and check if it has any in a wrong order but still the same.
=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0))
is this possible?
It will add the unique ref into the a Column which is 3 columns up from what every you set col equal to.
It also requires that col + 3 to be blank, this will make the checking easier.
Sub SomeSub()
Dim Array1 As Variant
Dim Array2 As Variant
With ActiveSheet.UsedRange
LastRow = .Rows(.Rows.Count).Row
End With
'Setting up the array for assigning each row value to the array
ReDim Array1((LastRow + 1))
ReDim Array2((LastRow + 1))
'Here youwill set what column is the "Number" Column
col = 1
'Assigning the row data into the arrays
'Starting at 2 to skip the title row
For r = 2 To LastRow
'Values in Column 1 go to Array1
Array1(r) = Cells(r, col)
'Values in Column 2 go to Array2
Array2(r) = Cells(r, col + 1)
Next r
'Setting unquie ref to 1
Seq = 1
'Running through each row of data
For i = 2 To LastRow
'col + 3 refers to a column on beyond the Sequence colum
'If the column is blank then that row has not been checked yet
If Cells(i, col + 3) = "" Then
'Assign the Uniqui ref to the row
Cells(i, col + 3).Value = Seq
'Running through the rest of the rows to check if they are like the current row
For n = i + 1 To (LastRow)
'If cell is blank then the row has been checked
If Cells(n, col + 3) = "" Then
'Array(i) is the current row
'Array(n) are the leading rows after row i
'If the current row is the same as any leading row then the uniquie ref = seq
If Array1(i) = Array1(n) And Array2(i) = Array2(n) Then Cells(n, col + 3).Value = Seq
'Else a value has been added
Else
'Do nothing
End If
Next n
'Increment the seq
Seq = Seq + 1
'Ending the If Cells(i, col + 3) = "" Then
End If
Next i
End Sub
You can first loop through the column and get the unique items using collections.
This part of the code:
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
Will only get the unique items, as a collection of items cannot have duplicates.
Use this to Number the duplicates.Change the sheet name as required.
Sub NumberDupes()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim LstRw As Long
Dim c As Long, clr As Long, x, r As Range
Set sh = Sheets("Sheet2")
With sh
.Columns("B:B").ClearContents
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1))
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 1
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For c = 1 To LstRw
Set r = .Cells(c, 1)
x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r)
If r = vNum Then
If x > 1 Then
r.Offset(, 1) = clr
End If
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
Use this to Color the Duplicates, this will work on a small scale, depends on how many unique items there are, it's cool example though. Edited code from my answer here.
Sub ColorDupes()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim LstRw As Long
Dim c As Long, clr As Long, x, r As Range
Set sh = Sheets("Sheet2")
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1))
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 3
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For c = 1 To LstRw
Set r = .Cells(c, 1)
x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r)
If r = vNum Then
If x > 1 Then
r.Interior.ColorIndex = clr
End If
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
In C1 just 1 and in C2:
=MIN(IF(($A$2:A2=A3)*($B$2:B2=B3),$D$2:D2,MAX($D$2:D2)+1))
This is an array formula and must be confirmed with Ctrl+Shift+Enter.
and simply autofill down from C3
hmm... i think i got it wrong :/
if only looking at Column A then this should be enough:
=MIN(IF($A$2:A2=A3,$D$2:D2,MAX($D$2:D2)+1))
This is an array formula and must be confirmed with Ctrl+Shift+Enter.
looking at your formula it can be shortened:
=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0))
'IF(A2=A1,TRUE,FALSE)=FALSE ==>> A1<>A2
=IF(IF(A1<>A2,1,0)>=0,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0))
'IF(A1<>A2,1,0)>=0 ==>> TRUE
=IF(TRUE,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0))
'IF(TRUE => allways true
=IF(A1<>A2,1,0)+D1
'last skip
=D1+(A1<>A2)
In my Excel worksheet I have something like this:
1 2 3
John Paul Mike
1 John 0 1 1
2 Paul 1 0
3 Mike 1 0
Which is similar to a symmetric matrix. Note that:
Each person has an ID;
For simplification, I set the values to 1's, but they can go from 1
to 20. 0's will always be 0's. There are also some blank spaces.
What I need is a macro that goes through the "matrix" and outputs the values into another worksheet in the following format:
From To Strenght
1 2 1
1 3 1
2 1 1
3 1 1
This is what I have so far, but isn't working because it return the error "The object is required", pointing to strenghts.
Dim i As Integer, j As Integer, strenghts As Integer
Set currentCell = Worksheets("Raw_Relationships").Cells(3, 3)
For i = 1 To 145
For j = 1 To 145
If currentCell <> "" Then
Set currentCell = Worksheets("Raw_Relationships").Cells(i, j).Offset(2, 3)
Set strenghts = Worksheets("Raw_Relationships").Cells(i, j).Offset(2, 2).Value
Set Worksheets("Gephi_Data").Cells(i, 1).Offset(150, 0).Value = i
Set Worksheets("Gephi_Data").Cells(i, 2).Offset(150, 0).Value = j
Set Worksheets("Gephi_Data").Cells(i, 3).Offset(150, 0).Value = strenghts
End If
Next j
Next i
Any tips on how to do this?
There are many ways to achieve what you want. Here is a very basic example of what you want.
Let's say your sheet looks like this
Use this code. I have commented the code so that you shouldn't have a problem understanding it. If you do then simply ask :)
Code
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim i As Long, j As Long
Dim rw As Long, col As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> This is where the output will be generated
rw = 2: col = 8
With ws
'~~> Create Headers of Output
.Cells(1, col).Value = "From"
.Cells(1, col + 1).Value = "To"
.Cells(1, col + 2).Value = "Strength"
'~~> Looping through rows
For i = 3 To 5
'~~> Looping through columns
For j = 3 To 5
'~~> Check if the cell is > 0
If .Cells(i, j).Value > 0 Then
'~~> Write the `From` column
.Cells(rw, col).Value = .Cells(i, 1).Value
'~~> Write the `To` Column
.Cells(rw, col + 1).Value = .Cells(1, j).Value
'~~> Write the `Strength` Column
.Cells(rw, col + 2).Value = .Cells(i, j).Value
rw = rw + 1
End If
Next j
Next i
End With
End Sub
Output
I am generating the output in Col H onwards. Change as applicable.
Get rid of Set in Set strenghts = .... Just write strenghts = .... Set is only used to set references to objects. strenghts isn't an object, it's a numeric value.
Also, I'm not sure if the typo in strenghts is intentional, but it's usually spelled "strengths".