T'm trying to format n ranges of 4 columns like below, expanding to the right and separated by a blank column (col "E"). The range 2 starts at column "F".
range 1
A B C D ...
X Action1 X X
-
-
X Action2 X X
X Action3 X X
#N/A #N/A #N/A
For each range, I want to remove rows (of 4 columns) containing "-" on the second column or "#N/A" on any column of the range, expecting this result :
range 1
A B C D ...
X Action1 X X
X Action2 X X
X Action3 X X
This is a part of a VBA macro so I won't use manual autofilters. On top, autofiltering would remove also rows from other ranges, which is not expected.
I'm trying this code at least for testing on the 1st block, even not working :
Dim Rng As Range
Set Rng = Range("A4", "D53")
If Not Rng(, 2).Value = "-" Then
Rng.Delete Shift:=xlUp
End If
edit : I guess the answer may not be far away from this but I can't manage it properly.
Lost in VBA, some help would be great, thx in advance
EDIT: if it may help someone, I ended up with this working code thx to the below hints :
Dim iRows, iCols, NbLig, x, BlockSize, BlockOffset, MyOffsetBtwnBlocks, CountBlocks As Integer
BlockSize = 4
NbLig = Range("A3").SpecialCells(xlCellTypeLastCell).Row
CountBlocks = 0
For iCols = 2 To NbCol Step BlockSize + 1
iRows = Range(Cells(3, iCols), Cells(NbLig, iCols + BlockSize).End(xlToLeft)).Rows.Count
For x = iRows To 3 Step -1
If Application.WorksheetFunction.IsNA(Cells(x, iCols + 1)) Then
Application.Intersect(Cells(x, iCols + 1).EntireRow, _
Range(Cells(3, iCols), Cells(3, iCols + BlockSize)).EntireColumn).Delete
ElseIf Application.WorksheetFunction.IsNA(Cells(x, iCols + 2)) Then
Application.Intersect(Cells(x, iCols + 2).EntireRow, _
Range(Cells(3, iCols), Cells(3, iCols + BlockSize)).EntireColumn).Delete
ElseIf Cells(x, iCols + 1).Value = "-" Then
Application.Intersect(Cells(x, iCols + 1).EntireRow, _
Range(Cells(3, iCols), Cells(3, iCols + BlockSize)).EntireColumn).Delete
End If
CountBlocks = CountBlocks + 1
Next x
Next iCols
This should do you:
Sub RemoveX()
Dim iRows As Integer
Dim x As Integer
Application.ScreenUpdating = False
iRows = Range("A1").CurrentRegion.Rows.Count
For x = iRows To 1 Step -1
If Application.WorksheetFunction.IsNA(Cells(x, 2)) Then
Application.Intersect(Cells(x, 2).EntireRow, _
Range("A1:D1").EntireColumn).Delete
ElseIf Cells(x, 2).Value = "-" Then
Application.Intersect(Cells(x, 2).EntireRow, _
Range("A1:D1").EntireColumn).Delete
End If
Next x
Application.ScreenUpdating = True
End Sub
CurrentRegion is the region obtained if you click into A1 and press Ctrl-A.
If could be tidied up a little (using Range references and not using EntireRow or -Column) but it works.
Related
I currently have a data set that looks like the following:
A B C D E F G
1 x x x x x x *
2 a a a a a a
3 c c c c c c %
I need code to copy paste rows at the bottom of the data set based on if there's text in column. I would then need the text in column G to appear in column F while everything else in the row stays the same. For example, the result would be:
A B C D E F G
1 x x x x x x *
2 a a a a a a
3 c c c c c c %
4 x x x x x *
5 c c c c c %
My code currently looks like this:
Public Sub CopyRows()
Sheets("Exposure Distribution").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
' Decide if to copy based on column H
ThisValue = Cells(x, 8).Value
If Application.WorksheetFunction.IsText(ThisValue) = "True" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("Exposure Distribution").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Exposure Distribution").Select
End If
ThisValue = Cells(x, 9).Value
If Application.WorksheetFunction.IsText(ThisValue) = "True" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("Exposure Distribution").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Exposure Distribution").Select
End If
ThisValue = Cells(x, 10).Value
If Application.WorksheetFunction.IsText(ThisValue) = "True" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("Exposure Distribution").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Exposure Distribution").Select
End If
Next x
End Sub
However I don't know how to accomplish the final part of what I'm looking for, which is moving data from column G to column F based on if there's text in `column G`.
See if this helps:
Sub CopyPasteWithConditions()
Dim wb As Workbook: Set wb = ActiveWorkbook 'declare and set the workbook
Dim ws As Worksheet: Set ws = wb.Sheets("SheetNameHere") 'declare and set the worksheet
Dim lRow As Long: lRow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'get the last row of current data
Dim cntTxts As Long: cntTxts = WorksheetFunction.CountA(Range("G1:G" & lRow)) 'get the number of times there is any text in G
Dim arrData As Variant: arrData = ws.Range("A1:G" & lRow + cntTxts) 'create an array of current data + number of rows required for the copied data
Dim R As Long, C As Long, X As Long
For R = LBound(arrData) To lRow 'for each row in current data
If arrData(R, 7) <> "" Then 'if there is any text in G
X = X + 1
For C = LBound(arrData, 2) To UBound(arrData, 2) - 1 'for each column in data, except last
If C = 6 Then 'if we are on the last column, get the extra text instead
arrData(lRow + X, C) = arrData(R, 7) 'add the value to the row equal to last row + value of X (pretty much the next free row)
Else 'else the other values
arrData(lRow + X, C) = arrData(R, C) 'add the value to the row equal to last row + value of X (pretty much the next free row)
End If
Next C
End If
Next R
ws.Range("A1:G" & lRow + cntTxts) = arrData 'put the data back on the sheet
End Sub
I have the following situation. In an Excel worksheet, I have a column which contains values that are separated by "|".
e.g.
Option Column
Option 1 | Option 3
Option 4 | Option 7
Option 2 | Option 3 | Option 6
I want to
1. Insert 10 columns to the right, name them "Option 1", "Option 2", "Option 3" ..... "Option 10"
2. In each cell of the first column, if "Option x" exists, split/copy/move to the column named "Option x" (Where x can be 1, 2 .... 10)
This is the code that I use currently to achieve it:
Sub Insert_10_columns()
Columns("B:K").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove
For i = 2 To 11
ActiveSheet.Cells(1, i).Value = "Option " & i - 1
Next i
End Sub
Sub Look_For_Text()
Dim LastRow As Long
LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow + 1
For k = 1 To 10
If InStr(1, (Cells(i, 1).Value), "Option " & k) > 0 Then
ActiveSheet.Cells(i, k + 1).Value = "Option " & k
End If
Next k
Next i
End Sub
I was just wondering if loops are the best way to go about it, especially because when I start using it, I would be operating on 20,000+ rows and 15+ columns.
Variant using System.Collections.ArrayList and Scripting.Dictionary, I guess that should be faster than your solution)
Sub test()
Dim data As Range, cl As Range, i&, x As Variant
Dim arrList As Object, Dic As Object
Set arrList = CreateObject("System.Collections.ArrayList")
Set Dic = CreateObject("Scripting.Dictionary")
Set data = Range([A2], Cells(Rows.Count, "A").End(xlUp))
'get unique values from split
For Each cl In data
For Each x In Split(cl, "|"): x = Trim(x)
If Not Dic.exists(x) Then
Dic.Add x, Nothing
arrList.Add x
End If
Next x, cl
Dic.RemoveAll 'clear dictionary
arrList.Sort 'sort values
If sortorder = xlDescending Then
arrList.Reverse
End If
'add headers
i = 2
For Each x In arrList
Cells(1, i).Value2 = x
Dic.Add x, i: i = i + 1
Next x
'split values against headers
For Each cl In data
For Each x In Split(cl, "|"): x = Trim(x)
Cells(cl.Row, Dic(x)).Value2 = x
Next x, cl
End Sub
test here
You will need a loop to walk through while you split the cell contents. Looping through an array is faster than looping through the worksheet. After splitting, populate a target array with matching columns before putting the target array values into the worksheet.
Option Explicit
Sub InsertOptions()
Dim i As Long, j As Long, mx As Long, dlm As String
Dim hdrs As Variant, opts As Variant, vals As Variant, tmp As Variant, m As Variant
dlm = " | " 'column A delimiter; might be " | "
mx = 15 'maximum number of options
With Worksheets("sheet9")
'create an independent array of header labels
ReDim hdrs(1 To 1, 1 To mx)
For i = LBound(hdrs, 2) To UBound(hdrs, 2)
hdrs(1, i) = "Option " & i
Next i
'collect the delimited options from column A
opts = Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2
'make room for all options in expanded form
ReDim vals(LBound(opts, 1) To UBound(opts, 1), _
LBound(hdrs, 2) To UBound(hdrs, 2))
'loop through delimited options, split them and look for matches in hdrs
For i = LBound(opts, 1) To UBound(opts, 1)
tmp = Split(opts(i, 1), dlm)
For j = LBound(tmp) To UBound(tmp)
m = Application.Match(tmp(j), hdrs, 0)
If Not IsError(m) Then
vals(i, m) = tmp(j)
End If
Next j
Next i
'insert ten new columns
.Cells(1, "B").Resize(1, UBound(hdrs, 2)).EntireColumn.Insert
'put arrays into new columns
With .Cells(1, "B").Resize(1, UBound(hdrs, 2)).EntireColumn
.ColumnWidth = 9
.Cells(1, 1).Resize(UBound(hdrs, 1), UBound(hdrs, 2)) = hdrs
.Cells(2, 1).Resize(UBound(vals, 1), UBound(vals, 2)) = vals
End With
End With
End Sub
This is the kind of transformation is what I am trying to perform.
For illustration I made this as table. Basically the first three columns should repeat for however many colors are available.
I searched for similar questions but could not find when I want multiple columns to repeat.
I found this code online
Sub createData()
Dim dSht As Worksheet
Dim sSht As Worksheet
Dim colCount As Long
Dim endRow As Long
Dim endRow2 As Long
Set dSht = Sheets("Sheet1") 'Where the data sits
Set sSht = Sheets("Sheet2") 'Where the transposed data goes
sSht.Range("A2:C60000").ClearContents
colCount = dSht.Range("A1").End(xlToRight).Column
'// loops through all the columns extracting data where "Thank" isn't blank
For i = 2 To colCount Step 2
endRow = dSht.Cells(1, i).End(xlDown).Row
For j = 2 To endRow
If dSht.Cells(j, i) <> "" Then
endRow2 = sSht.Range("A50000").End(xlUp).Row + 1
sSht.Range("A" & endRow2) = dSht.Range("A" & j)
sSht.Range("B" & endRow2) = dSht.Cells(j, i)
sSht.Range("C" & endRow2) = dSht.Cells(j, i).Offset(0, 1)
End If
Next j
Next i
End Sub
I tried changing step 2 to 1 and j to start from 4.
Another example with two varied sets:
Here's a generic "unpivot" approach (all "fixed" columns must appear on the left of the columns to be unpivoted)
Test sub:
Sub Tester()
Dim p
'get the unpivoted data as a 2-D array
p = UnPivotData(Sheets("Sheet1").Range("A1").CurrentRegion, _
3, False, False)
With Sheets("Sheet1").Range("H1")
.CurrentRegion.ClearContents
.Resize(UBound(p, 1), UBound(p, 2)).Value = p 'populate array to sheet
End With
'EDIT: alternative (slower) method to populate the sheet
' from the pivoted dataset. Might need to use this
' if you have a large amount of data
'Dim r As Long, c As Long
'For r = 1 To Ubound(p, 1)
'For c = 1 To Ubound(p, 2)
' Sheets("Sheet2").Cells(r, c).Value = p(r, c)
'Next c
'Next r
End Sub
UnPivot function - should not need any modifications:
Function UnPivotData(rngSrc As Range, fixedCols As Long, _
Optional AddCategoryColumn As Boolean = True, _
Optional IncludeBlanks As Boolean = True)
Dim nR As Long, nC As Long, data, dOut()
Dim r As Long, c As Long, rOut As Long, cOut As Long, cat As Long
Dim outRows As Long, outCols As Long
data = rngSrc.Value 'get the whole table as a 2-D array
nR = UBound(data, 1) 'how many rows
nC = UBound(data, 2) 'how many cols
'calculate the size of the final unpivoted table
outRows = nR * (nC - fixedCols)
outCols = fixedCols + IIf(AddCategoryColumn, 2, 1)
'resize the output array
ReDim dOut(1 To outRows, 1 To outCols)
'populate the header row
For c = 1 To fixedCols
dOut(1, c) = data(1, c)
Next c
If AddCategoryColumn Then
dOut(1, fixedCols + 1) = "Category"
dOut(1, fixedCols + 2) = "Value"
Else
dOut(1, fixedCols + 1) = "Value"
End If
'populate the data
rOut = 1
For r = 2 To nR
For cat = fixedCols + 1 To nC
If IncludeBlanks Or Len(data(r, cat)) > 0 Then
rOut = rOut + 1
'Fixed columns...
For c = 1 To fixedCols
dOut(rOut, c) = data(r, c)
Next c
'populate unpivoted values
If AddCategoryColumn Then
dOut(rOut, fixedCols + 1) = data(1, cat)
dOut(rOut, fixedCols + 2) = data(r, cat)
Else
dOut(rOut, fixedCols + 1) = data(r, cat)
End If
End If
Next cat
Next r
UnPivotData = dOut
End Function
Here is one way (fastest?) using arrays. This approach is better that the linked question as it doesn't read and write to/from range objects in a loop. I have commented the code so you shouldn't have a problem understanding it.
Option Explicit
Sub Sample()
Dim wsThis As Worksheet, wsThat As Worksheet
Dim ThisAr As Variant, ThatAr As Variant
Dim Lrow As Long, Col As Long
Dim i As Long, k As Long
Set wsThis = Sheet1: Set wsThat = Sheet2
With wsThis
'~~> Find Last Row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Find total value in D,E,F so that we can define output array
Col = Application.WorksheetFunction.CountA(.Range("D2:F" & Lrow))
'~~> Store the values from the range in an array
ThisAr = .Range("A2:F" & Lrow).Value
'~~> Define your new array
ReDim ThatAr(1 To Col, 1 To 4)
'~~> Loop through the array and store values in new array
For i = LBound(ThisAr) To UBound(ThisAr)
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
'~~> Check for Color 1
If ThisAr(i, 4) <> "" Then ThatAr(k, 4) = ThisAr(i, 4)
'~~> Check for Color 2
If ThisAr(i, 5) <> "" Then
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 4) = ThisAr(i, 5)
End If
'~~> Check for Color 3
If ThisAr(i, 6) <> "" Then
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 4) = ThisAr(i, 6)
End If
Next i
End With
'~~> Create headers in Sheet2
Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value
'~~> Output the array
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
End Sub
SHEET1
SHEET2
The addition of the LET function allows for this non-VBA solution.
=LET(data,B3:F6,
dataRows,ROWS(data),
dataCols,COLUMNS(data),
rowHeaders,OFFSET(data,0,-1,dataRows,1),
colHeaders,OFFSET(data,-1,0,1,dataCols),
dataIndex,SEQUENCE(dataRows*dataCols),
rowIndex,MOD(dataIndex-1,dataRows)+1,
colIndex,INT((dataIndex-1)/dataRows)+1,
FILTER(CHOOSE({1,2,3}, INDEX(rowHeaders,rowIndex), INDEX(colHeaders,colIndex), INDEX(data,rowIndex,colIndex)), index(data,rowIndex,colIndex)<>""))
Below is a custom function I wrote for such things (demo video I posted on YouTube). A few differences from other answers:
The custom function allows for more than one axis in columns. As shown below, the column axis has Currency and Time.
Row axis does not need to be directly next to the data range.
One can specify the entire row as the column axis or the entire column to specify the row axis. See formula used as example below.
So with this data set:
And entering this as the formula:
=unPivotData(D4:G7,2:3,B:C)
an output of this:
Function unPivotData(theDataRange As Range, theColumnRange As Range, theRowRange As Range, _
Optional skipZerosAsTrue As Boolean, Optional includeBlanksAsTrue As Boolean)
'Set effecient range
Dim cleanedDataRange As Range
Set cleanedDataRange = Intersect(theDataRange, theDataRange.Worksheet.UsedRange)
'tests Data ranges
With cleanedDataRange
'Use intersect address to account for users selecting full row or column
If .EntireColumn.Address <> Intersect(.EntireColumn, theColumnRange).EntireColumn.Address Then
unPivotData = "datarange missing Column Ranges"
ElseIf .EntireRow.Address <> Intersect(.EntireRow, theRowRange).EntireRow.Address Then
unPivotData = "datarange missing row Ranges"
ElseIf Not Intersect(cleanedDataRange, theColumnRange) Is Nothing Then
unPivotData = "datarange may not intersect column range. " & Intersect(cleanedDataRange, theColumnRange).Address
ElseIf Not Intersect(cleanedDataRange, theRowRange) Is Nothing Then
unPivotData = "datarange may not intersect row range. " & Intersect(cleanedDataRange, theRowRange).Address
End If
'exits if errors were found
If Len(unPivotData) > 0 Then Exit Function
Dim dimCount As Long
dimCount = theColumnRange.Rows.Count + theRowRange.Columns.Count
Dim aCell As Range, i As Long, g As Long
ReDim newdata(dimCount, i)
End With
'loops through data ranges
For Each aCell In cleanedDataRange.Cells
With aCell
If .Value2 = "" And Not (includeBlanksAsTrue) Then
'skip
ElseIf .Value2 = 0 And skipZerosAsTrue Then
'skip
Else
ReDim Preserve newdata(dimCount, i)
g = 0
'gets DimensionMembers members
For Each gcell In Union(Intersect(.EntireColumn, theColumnRange), _
Intersect(.EntireRow, theRowRange)).Cells
newdata(g, i) = IIf(gcell.Value2 = "", "", gcell.Value)
g = g + 1
Next gcell
newdata(g, i) = IIf(.Value2 = "", "", .Value)
i = i + 1
End If
End With
Next aCell
unPivotData = WorksheetFunction.Transpose(newdata)
End Function
I am trying to write a macro in VBA to transpose columns to rows in this style:
it is:
A
B
C
D
E
F
should be:
A D
B E
C F
Has someone any idea?
This should work for you:
Sub test()
Dim lastRow&, groupSize&, i&, k&
Dim rng As Range
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
groupSize = 13
k = 2 ' start the pasting in the second column
For i = 14 To lastRow
Set rng = Range(Cells(i, 1), Cells(i + groupSize - 1, 1))
rng.Cut Range(Cells(1, k), Cells(13, k))
i = i + 12
k = k + 1
Next i
End Sub
This is a modification of the correct answer of BruceWayne:
Sub test()
Dim lastRow&, groupSize&, i&, k&
Dim rng As Range
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
groupSize = 13
k = 1 ' start the pasting in the first column
j = 1
For i = 1 To lastRow
Set rng = Range(Cells(i, 1), Cells(i + groupSize - 1, 1))
rng.Cut Range(Cells(j, k), Cells(j + 12, k))
k = k + 1
i = i + 12
If k = 14 Then
k = 1
j = j + 13
End If
Next i
End Sub
The only difference is that now the data are written not in a single row but in a group of rows. All credits to BruceWayne.
I need to loop over all rows (except my header rows) and merge all cells with the same value in the same column. Before I do this I already made sure, that the column is sorted.
So I have some setup like this.
a b c d e
1 x x x x
2 x x x x
2 x x x x
2 x x x x
3 x x x x
3 x x x x
And need this
a b c d e
1 x x x x
2 x x x x
x x x x
x x x x
3 x x x x
x x x x
With my code I achieved to merge two equal cells. Instead I need to merge all equal cells.
Dim i As Long
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(i, 1) <> "" Then
If Cells(i, 1) = Cells(i - 1, 1) Then
Range(Cells(i, 1), Cells(i - 1, 1)).Merge
End If
End If
Next i
This method does not use merged cells, but achieves the same visual effect:
Say we start with:
Running this macro:
Sub HideDups()
Dim N As Long, i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 3 Step -1
With Cells(i, 1)
If .Value = Cells(i - 1, 1).Value Then
.Font.ColorIndex = 2
End If
End With
Next i
End Sub
will produce this result:
NOTE:
No cells are merged. This visual effect is the same because consecutive duplicates in the same column are "hidden" by having the colour of the font be the same as the colour of the cell background.
I know this is an old thread, but I needed something similar. Here's what I came up with.
Sub MergeLikeCells()
Dim varTestVal As Variant
Dim intRowCount As Integer
Dim intAdjustment As Integer
ActiveSheet.Range("A1").Select
'Find like values in column A - Merge and Center Cells
While Selection.Offset(1, 0).Value <> ""
'If instead you have blanks in the column, change the prev statement to While Selection.Offset(1, 0).Value <> "." and add "." to the last 2 rows of the data
intRowCount = 1
varTestVal = Selection.Value
While Selection.Offset(1, 0).Value = varTestVal
intRowCount = intRowCount + 1
Selection.Offset(1, 0).Select
Selection.ClearContents
Wend
intAdjustment = (intRowCount * -1) + 1
Selection.Offset(intAdjustment, 0).Select
Selection.Resize(intRowCount, 1).Select
With Selection
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.Offset(1, 0).Resize(1, 1).Select
Wend
End Sub
My solution as below, have a good day!
Sub MergeSameValue()
Application.DisplayAlerts = False
Dim LastRow As Integer
Dim StartRow As Integer
StartRow = 2
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim StartMerge As Integer
StartMerge = StartRow
For i = StartRow + 1 To LastRow
If Cells(i, 1) <> "" Then
If Cells(i, 1) <> Cells(i - 1, 1) Then
Range(Cells(i - 1, 1), Cells(StartMerge, 1)).Merge
StartMerge = i
End If
End If
Next i
End Sub