I am trying to transform my data in columns to a single column.
Example data:
A B C
1 2 3
D E F
I want it in a single column:
A
1
D
B
2
E
C
3
F
I am using this code I found on the web.
Sub ConvertRangeToColumn()
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
xTitleId = "KutoolsforExcel"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Rows
Rng.Copy
Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
This turns my data to:
A
B
C
1
2
3
D
E
F
As it seeks the data horizontally.
Try,
dim c as long, r as long
for c= 2 to cells(1, columns.count).end(xltoleft).column
for r=1 to cells(rows.count, c).end(xlup).row
cells(rows.count, "A").end(xlup).offset(1, 0) = cells(r,c)
next r
columns(c).clear
next c
I only made 3 adjustments here to fit the code you found to work for your situation.
Sub ConvertRangeToColumn()
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Columns
Rng.Copy
Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=False
rowIndex = rowIndex + Rng.Rows.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Using mostly your code:
Sub ConvertRangeToColumn()
Dim xTitleId$
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
xTitleId = "KutoolsforExcel"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Columns
Rng.Copy
Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=False
rowIndex = rowIndex + Rng.Rows.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
you could avoid paste special and consequent clipboard clearance by handling range values only:
Sub ConvertRangeToColumn()
Dim Range2 As Range
Dim xTitleId As String
Dim iCol As Long
xTitleId = "KutoolsforExcel"
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8) 'get cell where to start writing down
With Application.InputBox("Source Ranges:", xTitleId, Selection.Address, Type:=8) ' get and reference the 2D range to be "transformed" into 1 column
For iCol = 1 To .Columns.Count ' loop through referenced range columns
Range2.Offset((iCol - 1) * .Rows.Count, 0).Resize(.Rows.Count).Value = .Columns(iCol).Value ' write referenced range current column values into 'Range2 proper row offset'
Next
End With
End Sub
You could use Power Query, available in Windows Excel 2010+ and Office 365
Given how you want it to be ordered
Transpose
Unpivot after selecting all of the columns
Delete the Attribute column
Note: when creating the table, since there are no headers, be sure to deselect the box that says "my table has headers"
M Code
let
Source = Excel.CurrentWorkbook(){[Name="Table7"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type any}, {"Column2", type any}, {"Column3", type any}}),
#"Transposed Table" = Table.Transpose(#"Changed Type"),
#"Unpivoted Columns" = Table.UnpivotOtherColumns(#"Transposed Table", {}, "Attribute", "Value"),
#"Removed Columns" = Table.RemoveColumns(#"Unpivoted Columns",{"Attribute"}),
#"Changed Type1" = Table.TransformColumnTypes(#"Removed Columns",{{"Value", type text}})
in
#"Changed Type1"
If you dispose of the new dynamic Excel functions ArrayToText and Transpose (Excel/MS365) you might use a simple udf:
Public Function Split2Col(rng As Range)
Dim tmp: tmp = Evaluate("ArrayToText(Transpose(" & rng.Address(False, False, External:=True) & "))")
Split2Col = Application.Transpose(Split(tmp, ", "))
End Function
Related
I'm am trying to automatically filter a column and copy/paste all the unique values to a new sheet each. Here's the code that I have been working with, however I'm facing this error when running the code:
Run-time error '1004': The extract range has a missing or invalid field name.
Sub Filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String
'specify sheet name in which the data is stored
sht = "Filter This"
'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "C").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:H" & last)
Sheets(sht).Range("C1:C" & last).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("AA1"), _
Unique:=True
For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=3, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x
'Turn off filter
Sheets(sht).AutoFilterMode = False
With Application
.ScreenUpdating = True
.CutCopyMode = False
End With
End Sub
You can use collections to filter out the unique items, instead of using the advanced filter.
Sub UsingCollection()
Dim cUnique As Collection, ws As Worksheet, fRng As Range
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Set sh = ThisWorkbook.Sheets("Filter This")
Set Rng = sh.Range("C2:C" & sh.Cells(sh.Rows.Count, "C").End(xlUp).Row)
Set cUnique = New Collection
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
With sh
Set fRng = .Range("C1:H" & .Cells(.Rows.Count, "C").End(xlUp).Row)
End With
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
With ws
.Name = vNum
With fRng
.AutoFilter Field:=3, Criteria1:=vNum
fRng.Copy ws.Range("A1")
End With
.AutoFilterMode = False
End With
Next vNum
End Sub
I am working on the below code to insert same entire row below/beneath original one. I had a hard time fulfilling the requirement because I am just new to making macros.
I already tried searching but not able to code correctly. It is working to insert an empty row. But what I need is to insert the row that met the condition. Below is the screenshot/code for my macro.
Private Sub CommandButton1_Click()
Dim rFound As Range, c As Range
Dim myVals
Dim i As Long
myVals = Array("LB") '<- starts with 51, VE etc
Application.ScreenUpdating = False
With Range("F1", Range("F" & Rows.Count).End(xlUp))
For i = 0 To UBound(myVals)
.AutoFilter field:=1, Criteria1:=myVals(i)
On Error Resume Next
Set rFound = .Offset(2).Resize(.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
If Not rFound Is Nothing Then
For Each c In rFound
Rows(c.Row + 1).Insert
c.Offset(1, -1).Value = ActiveCell.Value
Next c
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub Test()
Dim rng As Range
Dim rngData As Range
Dim rngArea As Range
Dim rngFiltered As Range
Dim cell As Range
Set rng = Range("A1").CurrentRegion
'Exclude header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=6, Criteria1:="LB"
Set rngFiltered = rngData.Columns("F:F").SpecialCells(xlCellTypeVisible)
rng.AutoFilter Field:=6
For Each rngArea In rngFiltered.Areas
For Each cell In rngArea
'// When inserting a row,
'// iteration variable "cell" is adjusted accordingly.
Rows(cell.Row + 1).Insert
Rows(cell.Row).Copy Rows(cell.Row + 1)
Next
Next
End Sub
Below is the code I just used . Thank you!
Private Sub CommandButton2_Click()
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
End if
Next x
End Sub
I have 2 sheets : in the first i have date and in sheet2 i have a list of names in column A . I want to delete all the rows that don't have the names from sheet2 in the column O from the first sheet. The code just deletes everything from the first sheet. Any help is welcomed.
Sub Demo()
Dim Rng As Range, List As Object, Rw As Long
Dim x As Date
x = Now()
Set List = CreateObject("Scripting.Dictionary")
With Sheets("Sheet2")
For Each Rng In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
If Not List.Exists(Rng.Value) Then
List.Add Rng.Value, Nothing
End If
Next
End With
With Sheets("query " & Format(x, "dd.mm.yyyy"))
For Rw = .Range("O" & Rows.Count).End(xlUp).Row To 1 Step -1
If Not List.Exists(.Cells(Rw, "O").Value) Then
.Rows(Rw).Delete
End If
Next
End With
Set List = Nothing
End Sub
I'm not sure if this does exactly what you wants, but it does something very similar. To be clear:
Marks the cell adjacent to the list of names in Sheet1, if the name is found, then subsequently deletes the entire row if the the cell in said adjacent column is empty.
Sub Macro()
Dim r As Long
Dim r2 As Long
Dim counter As Long
Dim counter2 As Long
Range("O1").Select
Selection.End(xlDown).Select
r = ActiveCell.Row
Sheets(ActiveSheet.Index + 1).Select
Range("A1").Select
Selection.End(xlDown).Select
r2 = ActiveCell.Row
Range("A1").Select
For counter = 1 To r2
needle = ActiveCell.Value
Sheets(ActiveSheet.Index - 1).Select
On Error GoTo NotFound
Range(Cells(1, 15), Cells(r, 15)).Find(needle).Select
Selection.Offset(0, 1).Value = "found"
NotFound:
Sheets(ActiveSheet.Index + 1).Select
Selection.Offset(1, 0).Select
Next
Sheets(ActiveSheet.Index - 1).Select
Range("P1").Select
For counter2 = 1 To r
If ActiveCell.Value = "" Then Selection.EntireRow.Delete
Selection.Offset(1, 0).Select
Next
Cleanup:
Range("P1:P10000").Value = ""
End Sub
It is however, rather ugly and inefficient code. Lmk if there's something that needs changing!
i would do it like this:
Dim i as integer
dim x as integer
Dim rngSearch as Range
Dim strName as String
Dim ws1 as Worksheet
dim ws2 as Worksheet
Set ws1 = Thisworkbook.worksheets(1)
Set ws2 = Thisworkbook.worksheets(2)
x = ws1.cells(ws1.rows.count,1).end(xlup).row
for i = 2 to x
strName = ws1.cells(i, 1)
set rngSearch = ws2.columns(15).find(strName)
if rngSeach is nothing then
ws1.rows(i).entirerow.delete
i = i-1
end if
next i
It's not tested but it should work like this.
Edit: I think you have to put the worksheets in right order. I think i mixed them up here.
I am trying to join cells in a row if a value exists in a cell in that row.
The data has been imported from a .txt file and various sub headers are split along 2, 3 or 4 columns.
The cells cant be merged as the data will only be kept from the first cell.
The only words which are always constant are "contain" and "for" in column B.
What I've tried resembles this:
If cell.Value like "contain", or "for" then join all cells from column "A" to column "H" into column "B", align them centrally and make them bold.
thanks, in advance, for any help.
Edit Here is the code:
Sub Joining()
Dim N As Long, i As Long, r1 As Range, r2 As Range
Dim z As Long
Dim arr() As Variant
z = 1
With Activesheet
N = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If .Cells(i, "B").Value Like "Summary*" Then
arr = .Range(.Cells(i, "A"), .Cells(i, "H")).Value
.Cells(z, "B").Value = Join(arr, " ")
z = z + 1
End If
Next i
End With
End Sub
Not sure if this is exactly what you want but it will get you close:
Sub summary()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim N As Long, i As Long, r1 As Range, r2 As Range
Dim z As Long
Dim arr() As Variant
z = 1
Set sh1 = ActiveSheet
With ActiveWorkbook
Set sh2 = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
End With
With sh1
N = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If .Cells(i, "A").Value Like "Summary*" Then
arr = .Range(.Cells(i, "A"), .Cells(i, "H")).Value
sh2.Cells(z, "A").Value = Join(arr, " ")
z = z + 1
End If
Next i
End With
End Sub
Ok, so I've created an answer, but it ain't pretty (kinda like the whole project I've created).
It works although I'm sure there is a much simpler way of creating it.
Maybe someone can have a go at cleaning it up?
Sub SelRows()
Dim ocell As Range
Dim rng As Range
Dim r2 As Range
For Each ocell In Range("B1:B1000")
If ocell.Value Like "*contain*" Then
Set r2 = Intersect(ocell.EntireRow, Columns("A:G"))
If rng Is Nothing Then
Set rng = Intersect(ocell.EntireRow, Columns("A:G"))
Else
Set rng = Union(rng, r2)
End If
End If
Next
Call JoinAndMerge
If Not rng Is Nothing Then rng.Select
Set rng = Nothing
Set ocell = Nothing
End Sub
Private Sub JoinAndMerge()
Dim outputText As String, Rw As Range, cell As Range
delim = " "
Application.ScreenUpdating = False
For Each Rw In Selection.Rows
For Each cell In Rw.Cells
outputText = outputText & cell.Value & delim
Next cell
With Rw
.Clear
.Cells(1).Value = outputText
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
outputText = ""
Next Rw
Application.ScreenUpdating = True
End Sub
I'm looking to improve my code to dynamically set ranges where data exist instead of hard coding the values. The starting value of the range will never change, but the ending value will if more month columns are added. What is the best way to approach this. Would be easier to make the range user defined?
Here's what I have:
The code will split data by unique group name starting at C5 into separate worksheets.
Public Sub Splitdatatosheets()
' Splitdatatosheets Macro
Dim Rng As Range
Dim Rng1 As Range
Dim vrb As Boolean
Dim sht As Worksheet
'Find unique value for splitting
Set Rng = Sheets("Sheet1").Range("C5")
'Find starting row to copy (Re-code to dynamically set)
Set Rng1 = Sheets("Sheet1").Range("A5:M5")
vrb = False
Do While Rng <> ""
For Each sht In Worksheets
If sht.Name = Left(Rng.Value, 31) Then
sht.Select
Range("A2").Select
Do While Selection <> ""
ActiveCell.Offset(1, 0).Activate
Loop
Rng1.Copy ActiveCell
ActiveCell.Offset(1, 0).Activate
Set Rng1 = Rng1.Offset(1, 0)
Set Rng = Rng.Offset(1, 0)
vrb = True
End If
Next sht
If vrb = False Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Left(Rng.Value, 31)
'Copy header rows (Re-code to dynamically set) to new worksheet first cell
Sheets("Sheet1").Range("A4:M4").Copy ActiveSheet.Range("A1")
Range("A2").Select
Do While Selection <> ""
ActiveCell.Offset(1, 0).Activate
Loop
Rng1.Copy ActiveCell
Set Rng1 = Rng1.Offset(1, 0)
Set Rng = Rng.Offset(1, 0)
End If
vrb = False
Loop
End Sub
Here's the updated code for anyone who stumbles across this question.
Public Sub Splitdatatosheets()
' Splitdatatosheets Macro
Dim rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim vrb As Boolean
Dim sht As Worksheet
Dim R_Start, R_End, H_Start, H_End As Range
'Set Header
Set H_Start = Cells(4, 1)
Set H_End = H_Start.End(xlToRight)
'Set Data range
Set R_Start = Cells(5, 1)
Set R_End = R_Start.End(xlToRight)
'Find unique value for splitting
Set rng = Sheets("Sheet1").Range("C5")
'Find starting row to copy
Set Rng1 = Range(R_Start, R_End)
Set Rng2 = Range(H_Start, H_End)
vrb = False
Do While rng <> ""
For Each sht In Worksheets
If sht.Name = Left(rng.Value, 31) Then
sht.Select
Range("A2").Select
Do While Selection <> ""
ActiveCell.Offset(1, 0).Activate
Loop
Rng1.Copy ActiveCell
ActiveCell.Offset(1, 0).Activate
Set Rng1 = Rng1.Offset(1, 0)
Set rng = rng.Offset(1, 0)
vrb = True
End If
Next sht
If vrb = False Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Left(rng.Value, 31)
'Copy header rows to new worksheet first cell
Rng2.Copy ActiveSheet.Range("A1")
Range("A2").Select
Rng1.Copy ActiveCell
Set Rng1 = Rng1.Offset(1, 0)
Set rng = rng.Offset(1, 0)
End If
vrb = False
Loop
End Sub