I have a table with 3 columns and 30 rows. I am trying to write a VBA macro that shifts first row with 1 cell to the right, the second row 2 cells to the right and so on.
For example, this
AAA
BBB
CCC
should look like this:
AAA
BBB
CCC
What I tried so far, could only move the whole selected range:
Sub Macro()
Set Table = Application.InputBox("Select table", Title:="Table", Type:=8)
Table.Cut Table.Offset(0, 1)
End Sub
This should be doing what you want:
Sub Macro()
Set Table = Application.InputBox("Select table", Title:="Table", Type:=8)
Set Dest = Application.InputBox("Select destination", Title:="Destination", Type:=8)
For i = 1 To Table.Rows.Count
For j = 1 To Table.Columns.Count
Table.Cells(i, j).Copy Dest.Cells(i + j - 1, i + 1)
Next j
Next i
End Sub
Before:
The code:
Sub asdfg()
Dim N As Long, i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
Cells(i, 1).Cut (Cells(i, i + 1))
Next i
End Sub
and after:
EDIT#1:
To shift the entire row use:
Sub zxcvb()
Dim N As Long, i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
Range(Cells(i, 1), Cells(i, i)).Insert Shift:=xlToRight
Next i
End Sub
Before:
and after:
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 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)
I want to copy data from one sheet to another with few conditions:
1. Start with row 1 and column 1 and match if the R1 C2 is not empty then copy the pair R1 C1 and R1 C2 and paste into the other sheet as a new row.
increment the counter for column and match R1 C1 with R1 C3 and so on.
increment the Row when the column counter reaches 10.
I tried the below code but gives compile error as Sub or function not defined.
Please help.
Private Sub CommandButton1_Click()
Dim x As Integer
Dim y As Integer
x = 2
y = 2
Do While Cells(x, 1) <> ""
If Cells(x, y) <> "" Then
Worksheets("Sheet1").Cells(x, 2).Copy
Worksheets("Sheet2").Activate
erow = Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(erow)
End If
Worksheets("Sheet1").Activate
y = y + 1
If y = 10 Then x = x + 1
End If
Loop
End Sub
You are geting that error because of > in Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
Avoid the use of using Integer when you are working with rows. Post excel2007, the row count has increased and the Integer may not be able to handle the row number.
Avoid the use of .Activate.
Is this what you are trying? (Untested)
Note: I am demonstrating and hence I am working with the excel cells directly. But in reality, I would be using autofilter & arrays to perform this operation.
Private Sub CommandButton1_Click()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim lRowInput As Long, lRowOutput As Long
Dim i As Long, j As Long
Set wsInput = ThisWorkbook.Worksheets("Sheet1")
Set wsOutput = ThisWorkbook.Worksheets("Sheet2")
With wsInput
lRowInput = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRowInput
If .Cells(i, 2).Value <> "" Then
For j = 3 To 10
lRowOutput = wsOutput.Range("A" & wsOutput.Rows.Count).End(xlUp).Row + 1
.Range(.Range(.Cells(i, 1), .Cells(i, 1)).Address & _
"," & _
.Range(.Cells(i, j), .Cells(i, j)).Address).Copy _
wsOutput.Range("A" & lRowOutput)
Next j
End If
Next i
End With
End Sub
If I have all data in one very long column like this:
A
B
C
1
2
3
D
E
F
4
5
6
G
H
I
7
8
9
Is it possible to move data like this?
Column1 Column2 Column3 Column4 Column5 Column6
A B C 1 2 3
D E F 4 5 6
G H I 7 8 9
I tried paste special+transpose , but I have more than 10 thousands records , so it will take me too much time in using this method.
I'm new in excel and macro , thank you very much.
Edit:
I even tried to transpose all data into many columns then select the column I want to make them all into one column with this macro:
Sub OneColumn()
' Jason Morin as amended by Doug Glancy
' http://makeashorterlink.com/?M19F26516
''''''''''''''''''''''''''''''''''''''''''
'Macro to copy columns of variable length
'into 1 continuous column in a new sheet
''''''''''''''''''''''''''''''''''''''''''
Dim from_lastcol As Long
Dim from_lastrow As Long
Dim to_lastrow As Long
Dim from_colndx As Long
Dim ws_from As Worksheet, ws_to As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws_from = ActiveWorkbook.ActiveSheet
from_lastcol = ws_from.Cells(1, Columns.Count).End(xlToLeft).Column
'Turn error checking off so if no "AllData" trying to delete doesn't generate Error
On Error Resume Next
'so not prompted to confirm delete
Application.DisplayAlerts = False
'Delete if already exists so don't get error
ActiveWorkbook.Worksheets("AllData").Delete
Application.DisplayAlerts = True
'turn error checking back on
On Error GoTo 0
'since you refer to "AllData" throughout
Set ws_to = Worksheets.Add
ws_to.Name = "AllData"
For from_colndx = 1 To from_lastcol
from_lastrow = ws_from.Cells(Rows.Count, from_colndx).End(xlUp).Row
'If you're going to exceed 65536 rows
If from_lastrow + ws_to.Cells(Rows.Count, 1).End(xlUp).Row <= 65536 Then
to_lastrow = ws_to.Cells(Rows.Count, 1).End(xlUp).Row
Else
MsgBox "This time you've gone to far"
Exit Sub
End If
ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _
from_colndx)).Copy ws_to.Cells(to_lastrow + 1, 1)
Next
' this deletes any blank rows
ws_to.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
But it will just join all column into one but not the column selected.
For Remou reference:
Here is the output:
A D G
B E H
C F I
1 4 7
2 5 8
3 6 9
You can look at something in these lines:
Sub TransposeColumn()
Dim rng As Range
Dim ws As Worksheet
Set rng = Worksheets("Input").UsedRange
Set ws = Worksheets("Output")
j = 1
k = 1
For i = 1 To rng.Rows.Count
If rng.Cells(i, 1) = vbNullString Then
j = j + 1
k = 1
Else
''ws.Cells(k, j) = rng.Cells(i, 1)
''EDIT
ws.Cells(j, k) = rng.Cells(i, 1)
k = k + 1
End If
Next
End Sub
This is how I do the same thing... it creates the new table in column C over...based on your example that there is a blank cell between each group of data:
Sub TransposeGroups()
Dim RNG As Range, Grp As Long, NR As Long
Set RNG = Range("A:A").SpecialCells(xlConstants)
NR = 1
For Grp = 1 To RNG.Areas.Count
RNG.Areas(Grp).Copy
Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True
NR = NR + 1
Next Grp
End Sub
This should work for any length of data and "groups" of up to 8500 within the data.
This also uses the AREAS method, but this overcomes the groups limitation by using subgroups, so it should work with any size dataset.
Sub TransposeGroups2()
'Uses the AREAS method and will work on any size data set
'overcomes the limitation of areas by working in subgroups
Dim RNG As Range, rngSTART As Range, rngEND As Range
Dim LR As Long, NR As Long, SubGrp As Long, Itm As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
NR = 1
SubGrp = 1
Set rngEND = Range("A" & SubGrp * 10000).End(xlUp)
Set RNG = Range("A1", rngEND).SpecialCells(xlConstants)
Do
For Itm = 1 To RNG.Areas.Count
RNG.Areas(Itm).Copy
Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True
NR = NR + 1
Next Itm
If rngEND.Row = LR Then Exit Do
Set rngSTART = rngEND.Offset(1)
SubGrp = SubGrp + 1
Set rngEND = Range("A" & (SubGrp * 10000)).End(xlUp)
Set RNG = Range(rngSTART, rngEND).SpecialCells(xlConstants)
Loop
End Sub