I need a little help, or a VBA script that can convert a big dataset (960000 rows) in the format like below. All the data are in one column
TRIP_ID | OBJECTID | CPR_VEJNAV | ADM_VEJSTA | ADM_VEJKLA | vejid | vejkl | Shape_Length
2626 | value | value | value | value | value | value | value
..
..
2626 | value | value | value | value | value | value | value
64646 | value | value | value | value | value | value | value
..
..
..
64646 | value | value | value | value | value | value | value
I would like to convert the data into multiple columns, one column for each TRIP_ID, like this:
TRIP_ID | ..... | TRIP_ID ..... | And so on
2626 | ..... | 64646 .....
..
..
2626 | ...... | 64646 .....
And so on, I have around 1800 TRIP_ID's
In short terms:
Convert from one long column, to multiple columns based on TRIP_ID
Always make a backup of your data before running someone else's code
Sub SplitToColumns()
Dim rCell As Range
Dim sCurrent As String
Dim rLast As Range
Dim lRowStart As Long
Application.EnableEvents = False
Set rLast = Sheet1.Range("A2").End(xlDown).Offset(1, 0)
rLast.Value = "End"
For Each rCell In Sheet1.Range("A2", rLast).Cells
If Split(rCell.Value, "|")(0) <> sCurrent Then
If lRowStart > 1 Then
rCell.Offset(lRowStart - rCell.Row, 0).Resize(rCell.Row - lRowStart, 1).Copy
Sheet1.Cells(2, Sheet1.Columns.Count).End(xlToLeft).Offset(0, 1).Resize(rCell.Row - lRowStart, 1).PasteSpecial xlValues
End If
lRowStart = rCell.Row
sCurrent = Split(rCell.Value, "|")(0)
End If
Next rCell
rLast.ClearContents
Application.CutCopyMode = False
Application.EnableEvents = True
End Sub
Related
My spreadsheet continuously refreshes data contained in the table based on a project number. There are 5 additional columns that contain manually inputted information (i.e. does not automatically refresh) associated with each project number. These columns essentially contain user comments and must stay associated with the project number through each refresh. When a refresh occurs, new project numbers may also be added to the list.
I am looking for a solution to store these 5 manually inputted columns with the project number.
Previously, we used a dictionary when only one key-value pairing was required. However, now we have multiple values for each key.
Public Function saveComments(rowOfCom As Integer, _
rowOfSafety As Integer, _
rowOfCompliance As Integer, _
rowOfCommercial As Integer, _
rowOfOperational As Integer, _
rowOfSIssue As Integer, _
ws As Worksheet) As Variant
'Sub is meant to save comments associated with masterplan id's
'We do this by first making one dictionary with every plan year and another
' dictionary that will store the mpids & comments
'Idea is to loop through each ws, store each mpid and comment then run macro
' to update mpids then paste in new comments
Dim mpDict As New Scripting.Dictionary
Dim numOfWS As Integer, count As Integer, rowCount As Integer, i As Integer
Dim rg As Range
Dim Key As Variant
Dim value As Variant
'Get the number of mpDictionaries needed. Counts the sheets if its a year
' or Not set just in case a sheet is added
With ws
rowCount = .Range("A1").End(xlDown).Row
For i = 2 To rowCount
If mpDict.Exists(.Cells(i, 1).value) = False Then
For j = 13 To j = 18
'Access the mpDict and store the MPID and Comment
mpDict.Add .Cells(i, 1).value, .Cells(i, j).value
Next j
End If
Next i
' Debug.Print (yearDict.Item(ws.Name).Item(.Cells(2, 1).value))
count = count + 1
End With
Set saveComments = mpDict
End Function
What I do in this case is to build a compound entry for each key. This can be in the form of a Class object, another Dictionary, a Collection or almost anything. For the simplest of situations though, I just create a CSV list.
For example, if my data is
+--------+----+
| red | 42 |
| green | 36 |
| blue | 49 |
| white | 44 |
| orange | 25 |
| black | 45 |
| purple | 32 |
| mauve | 41 |
| cherry | 14 |
| lemon | 32 |
| lime | 6 |
| red | 11 |
| green | 17 |
| blue | 13 |
| white | 9 |
| orange | 23 |
| black | 21 |
| purple | 38 |
| mauve | 19 |
| cherry | 22 |
| lemon | 42 |
| lime | 48 |
| red | 35 |
| green | 37 |
| blue | 44 |
| white | 6 |
| orange | 41 |
| black | 5 |
| purple | 15 |
| mauve | 20 |
+--------+----+
Then I'll build a using code similar to
Option Explicit
Sub BuildDictionaryExample()
Dim myDict As Dictionary
Set myDict = New Dictionary
Dim myData As Range
Set myData = Sheet1.Range("A1:B30")
Dim keyValue As Variant
Dim thisRow As Range
For Each thisRow In myData.Rows
keyValue = thisRow.Cells(1, 1)
If Not myDict.Exists(keyValue) Then
myDict.Add keyValue, thisRow.Cells(1, 2)
Else
Dim newValue As Variant
newValue = myDict(keyValue) & "," & thisRow.Cells(1, 2)
myDict(keyValue) = newValue
End If
Next thisRow
End Sub
I have this table and the VBA code has to fetch Value from Product where the Primary value is Yes. But, Value has to be the First Value in the Sequence.
+---------+---------+---------+
| Product | Results | Primary |
+---------+---------+---------+
| A | | |
| B | | Yes |
| C | | Yes |
| D | | |
| E | | Yes |
| F | | |
| G | | Yes |
| H | | Yes |
| I | | |
+---------+---------+---------+
Expecting results:
+---------+---------+---------+
| Product | Results | Primary |
+---------+---------+---------+
| A | | |
| B | A | Yes |
| C | A | Yes |
| D | | |
| E | D | Yes |
| F | | |
| G | F | Yes |
| H | F | Yes |
| I | | |
+---------+---------+---------+
I have tried this below vba code, but doesn't work as i expected.
Sub test()
Dim i As Long
Dim lr As Long
lr = ActiveSheet.UsedRange.Rows.Count
For i = 2 To lr
If Range("D" & i).Value = "Yes" Then
Range("C" & i).Value = Range("B" & i - 1).Value
End If
Next
End Sub
Excel Formula
Here is an example of how your formula can look. This first looks to see if the primary field is "Yes". If so, then it checks if the previous result also was a yes, and grabs it's the result if so. Otherwise, it grabs the first value based on your example.
=IF($C2="Yes", IF($C1="Yes", $B1, $A1),"")
Adjust this as needed!
VBA Code
I would suggest creating a way of finding your headers, that way it is easier to update down the road in case it changes or there are more fields added. Below I added an example of what I would attempt to do.
I used a helper function (Inject) to build the actual formula and make it easier to read/debug if there are issues.
Feel free to add your own custom error handling as well.
Just note this is one of many ways you could tackle this. I could even break this formula into even smaller components to abstract as much of it as possible.
Option Explicit
Private Sub AddResultsToTable()
Dim Ws As Worksheet
Set Ws = ActiveSheet
'FIND COLUMN HEADERS TO USE IN FORMULA REFERENCES
With Ws.UsedRange
On Error GoTo Catch
Dim Product As Range
Set Product = .Find("Product")
Dim Results As Range
Set Results = .Find("Results")
Dim Primary As Range
Set Primary = .Find("Primary")
End With
'CREATE FORMULA. Example: =IF($C2="Yes", IF($C1="Yes", $B1, $A1),"")
Dim CustomFormula As String
CustomFormula = Inject("=IF(${0}='Yes', IF(${1}='Yes', ${2}, ${3}),'')", _
Primary.Offset(1).Address(False, True), _
Primary.Address(False, True), _
Results.Address(False, True), _
Product.Address(False, True) _
)
'SET FIRST RANGE EQUAL TO FORMULA & AUTOFILL FORMULA DOWN
With Results.Offset(1)
.Value = CustomFormula
.AutoFill Range(.Address, Ws.Cells(Ws.Rows.Count, Product.Column).End(xlUp).Offset(, 1))
End With
Exit Sub
Catch:
'You can do your error handling here.
MsgBox Err.Description, vbCritical
End Sub
'METHOD THAT ALLOWS A STRING TO BE REPLACED WITH VARIABLES AND SPECIAL CHARACTERS
Public Function Inject(ByVal Source As String, ParamArray Args() As Variant) As String
'#AUTHOR: ROBERT TODAR
'#EXAMPLE: Inject("${0}, ${1}!", "Hello", "Robert") --> Hello, Robert!
'REPLACE SINGLE QUOTES WITH DOUBLE QUOTES
Inject = Source
Inject = Replace(Inject, "'", """")
'REPLACE ${#} WITH VALUES STORED IN THE VALUE IN THAT INDEX.
Dim Index As Integer
For Index = LBound(Args, 1) To UBound(Args, 1)
Inject = Replace(Inject, "${" & Index & "}", Args(Index), , , vbTextCompare)
Next Index
End Function
Assuming cols A B C use the below formula in B2
=If(C2="yes", if(B1="",A1,B1),"")
Copy this to all the linea below.
This will work as long as the first item is not primary.
U can even include this formula in vba and do the copy paste in vba
This is a follow up to my previous question (Retrieving information of OLEObjects from Workbook with VBA)
Scenario: I am trying to retrieve data from a worksheet. The data might be normal strings or number or might be encased in check boxed (checked or not).
Data example:
+---------+-------+------------------+------+------------------+
| item1 | 2004 | | | |
+---------+-------+------------------+------+------------------+
| value x | rfd | checkbox for rfd | nfd | checkbox for nfd |
+---------+-------+------------------+------+------------------+
| ident | test7 | call3 | | |
+---------+-------+------------------+------+------------------+
Obs: In this example the "checkbox for rfd/nfd" is a normal checkbox (either form or activex), and depending on the item in that sheet, either might be selected.
Objective: What I am trying to do is read the worksheet in 2 steps: First read all the data that is directly called, so I use the code:
Sub Test_retrieve()
' this will get all non object values from the sheet
Dim array_test As Variant
Dim i As Long, j As Long
array_test = ThisWorkbook.Sheets(1).UsedRange
For i = 1 To ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To ThisWorkbook.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
ThisWorkbook.Sheets(2).Cells(i, j) = array_test(i, j)
Next j
Next i
End Sub
to get:
+---------+-------+------------------+------+------------------+
| item1 | 2004 | | | |
+---------+-------+------------------+------+------------------+
| value x | rfd | | nfd | |
+---------+-------+------------------+------+------------------+
| ident | test7 | call3 | | |
+---------+-------+------------------+------+------------------+
Next I am trying to reach all the objectives/shapes in my worksheet. I used the following code to get name, value (checked of not) and location of all activex objects:
Sub getavticeboxvalue()
' this will get the names and values (as binary) of all the activex controlbox objects in the sheet
Dim objx As Object
Dim i As Long
i = 1
For Each objx In ThisWorkbook.Sheets(1).OLEObjects
If objx.Object.Value = True Then
ThisWorkbook.Sheets(3).Cells(i, 1).Value = 1
ThisWorkbook.Sheets(3).Cells(i, 2).Value = objx.Name
ThisWorkbook.Sheets(3).Cells(i, 3).Value = objx.BottomRightCell.Address
ElseIf objx.Object.Value = False Then
ThisWorkbook.Sheets(3).Cells(i, 1).Value = 0
ThisWorkbook.Sheets(3).Cells(i, 2).Value = objx.Name
ThisWorkbook.Sheets(3).Cells(i, 3).Value = objx.BottomRightCell.Address
End If
i = i + 1
Next objx
End Sub
Which yields something like:
+-------+-----------+----------+
| value | name | location |
+-------+-----------+----------+
| 0 | checkbox1 | $C$2 |
+-------+-----------+----------+
| 1 | checkbox2 | $E$2 |
+-------+-----------+----------+
I would then proceed to feed the values (1s and 0s), to the first table, in the place where the checkboxes originally where (location).
Issue: When I try the same procedure for Form Control (instead of activex), I have less options, and although I can look for them (ThisWorkbook.Sheets(1).Shapes.Type = 8) I cannot find their name or location.
Question: Is there a way to find their name and location? Is there a more efficient way to reach the result?
Objective:
+---------+-------+------------------+
| item1 | 2004 | | | |
+---------+-------+------------------+
| value x | rfd | 0 | nfd | 1 |
+---------+-------+------------------+
| ident | test7 | call3 | | |
+---------+-------+------------------+
I have a table of data, and some of the data is garbage. There's about 30000 entries sorted by unit. I only care about 20 of those units. I can easily sort the data by applying a filter, but it's tedious to click the 23 or so times and I'm going to have to manage this report weekly.
I've captured the relevant criteria into a different sheet, all non-repeating values sorted into a column. I'd like to arrange another sheet so that it only displays the rows from my table if the data in their unit column matches the criteria column.
I know I need to use VLOOKUP... somehow, but I haven't stumbled across any tutorials that compare a cell's value to a table.
In case that was all very confusing:
My table:
Action | Job Desc | Dept
XFR | IT Guy | Home Office 1
POS | Security Guy| Satellite Office
TTL | Analyst Guy | Home Office 2
I want to have a new sheet that only contains 3 rows:
Action | Job Desc | Dept
XFR | IT Guy | Home Office 1
TTL | Analyst Guy | Home Office 2
I have the values "Home Office 1" and "Home Office 2" stored elsewhere (there are actually 28 different office values). How do I build this sheet so it only displays these values - similar to the stock Excel filter function?
I think the easiest way to do this is by creating a tab of "interesting" units and vlookup to this. In the new interesting tab you would list the 20 items you are interested in column A.
In the data tab with all 30,000 rows you need to add a new column to check each row if it exists in the interesting tab. I assume the units are in column C and you are entering this formula in cell D1 =NOT(ISERROR(VLOOKUP(C1,InterestingTab!A:A,1,0))).
The result of the formula is TRUE or FALSE, which can easily be filtered on. Then you can easily add new items to the interesting tab and it will update automatically.
A very common question.
Assuming that:
1) You are using Excel 2010 or later
2) The original table is in Sheet1!A1:C10 (with headers in row 1)
3) The table to house the (filtered) results is in Sheet2 and of an identical layout to the original table
4) The list of (28) criteria is in Sheet3!A2:A29
then enter this single formula in Sheet2!J1:
=SUMPRODUCT(COUNTIF(Sheet3!A2:A29,Sheet1!C2:C10))
Of course, the choice of cell here does not have to be J1, though, whatever you choose, make sure that it is a cell which is external to your results table. This formula is a one-off, and, unlike those in the main results table, NOT designed to be copied to any further cells; it simply determines the number of expected returns, and will be referenced in the main table formulas, thus avoiding resource-heavy IFERROR set-ups.
The formula in cell A2 of the results table is then:
=IF(ROWS($1:1)>$J$1,"",INDEX(Sheet1!A:A,AGGREGATE(15,6,ROW(Sheet1!B$2:B$10)/MATCH(Sheet1!$C$2:$C$10,Sheet3!$A$2:$A$29,0)^0,ROWS($1:1))))
and copied down and to the right as required.
Obviously if the upper row reference in your original table is not actually 10 then you will need to amend that part within these formulas accordingly. However, be sure not to choose an arbitrarily large value, since, for each additional cell referenced, extra calculation will be required (and that applies whether those additional cells are technically beyond the last-used cells in those ranges or not.)
As such, I recommend that you either choose a suitably low, though sufficient, upper bound for the end row being referenced or, even better, make your ranges dynamic, such that they automatically adjust as your data expands/contracts.
Regards
Here is my anser...
Sub takeMyValus()
Dim r1
Dim r2
Dim c
Dim rng1 As Range
Dim rng2 As Range
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht3 As Worksheet
Dim List()
Dim i
Dim j
r1 = Range("A1").End(xlDown).Row 'to know the last row
c = Range("A1").End(xlToRight).Column 'to know the last colum
Set sht1 = Sheets("Data") 'this is the name I used, but you
'put the name of your data sheet
Set sht2 = Sheets("List") 'the sheet with the sorted list of the data you want
sht1.Activate 'Just in case
Set rng1 = Range(Cells(1, 1), Cells(r1, c)) 'set just the range with data
rng1.AutoFilter 'set the autofilter
'is better if the data has no autofilter
'when you begin to run the macro
sht2.Activate
'imagine that you got the list in column A and is just 5 items in your data
'With no header
'+---------+
'| Office3 |
'| Home5 |
'| Office8 |
'| Home8 |
'| Sat2 |
'+---------+
'List for my example...
r2 = Range("A1").End(xlDown).Row 'to know the total item on the list
'in this case will be 5
Set rng2 = Range(Cells(1, 1), Cells(r2, 1)) 'set the range of the list
'that is Range("A1:A5")
j = 0 'ini the counter
For Each i In rng2 'for every cell in Range("A1:A5")
j = j + 1 'increase the j to 1 every time
ReDim Preserve List(1 To j)
'redimension the var...
List(j) = i.Value 'store every cell (just the data) into an array
Next i 'next one.
sht1.Activate 'go to sheet with all the data
rng1.AutoFilter Field:=3, Criteria1:=Array(List), Operator:=xlFilterValues 'set the filter with the list
rng1.SpecialCells(xlCellTypeVisible).Copy 'copy just the cells that you can see, this is the filter
Sheets.Add after:=Sheets(Sheets.Count) 'add a new sheet
ActiveSheet.Name = myTime 'put a diferent name, see the function below
Set sht3 = ActiveSheet 'store the new sheet into this var
sht3.Activate 'go to the new sheet... is already activate, but just in case...
Range("A1").PasteSpecial xlPasteAll 'paste all in Range("A1")
Application.CutCopyMode = False 'is like press ESCAPE in the keyboard
End Sub
Function myTime() As String 'the function a told you
Dim HH
Dim MM
Dim SS
Dim TT
HH = Hour(Now)
MM = Minute(Now)
SS = Second(Now)
myTime = Format(HH, "00") & Format(MM, "00") & Format(SS, "00")
End Function
Here is the example of my data...
+--------+---------+----------+
| Action | Job Des | Dept |
+--------+---------+----------+
| XFR | IT | Office1 |
| POS | Sec | Office2 |
| TTL | Analyst | Office3 |
| XFR | IT | Office4 |
| POS | Sec | Office5 |
| TTL | Analyst | Office6 |
| XFR | IT | Office7 |
| POS | Sec | Office8 |
| TTL | Analyst | Office9 |
| XFR | IT | Office10 |
| POS | Sec | Home1 |
| TTL | Analyst | Home2 |
| XFR | IT | Home3 |
| POS | Sec | Home4 |
| TTL | Analyst | Home5 |
| XFR | IT | Home6 |
| POS | Sec | Home7 |
| TTL | Analyst | Home8 |
| XFR | IT | Home9 |
| POS | Sec | Home10 |
| TTL | Analyst | Home11 |
| XFR | IT | Home12 |
| POS | Sec | Sat1 |
| TTL | Analyst | Sat2 |
| XFR | IT | Sat3 |
| POS | Sec | Sat4 |
| TTL | Analyst | Sat5 |
| XFR | IT | Sat6 |
| POS | Sec | Sat7 |
| TTL | Analyst | Sat8 |
| XFR | IT | Sat9 |
| POS | Sec | Sat10 |
| TTL | Analyst | Sat11 |
| XFR | IT | Sat12 |
| POS | Sec | Sat13 |
| TTL | Analyst | Sat14 |
+--------+---------+----------+
The list
+---------+
| Office3 |
| Home5 |
| Office8 |
| Home8 |
| Sat2 |
+---------+
The result:
+--------+---------+---------+
| Action | Job Des | Dept |
+--------+---------+---------+
| TTL | Analyst | Office3 |
| POS | Sec | Office8 |
| TTL | Analyst | Home5 |
| TTL | Analyst | Home8 |
| TTL | Analyst | Sat2 |
+--------+---------+---------+
I have a spreadsheet that has column E that requires values split (comma separated values currently) and transposed to multiple rows. Columns C, D, F-S need copied down. Example:
Columns
+-----+-------+------------------+-------+--------+--------+----------+
| C | D | E | F | G | H | ... S |
+-----+-------+------------------+-------+--------+--------+----------+
| 20 | hey | one, two, three | xyz | unit | right | ... end |
+-----+-------+------------------+-------+--------+--------+----------+
I need it to look like:
+-----+-------+--------+-------+--------+--------+---------+
| C | D | E | F | G | H | ... S |
+-----+-------+--------+-------+--------+--------+---------+
| 20 | hey | one | xyz | unit | right | ... end |
| 20 | hey | two | xyz | unit | right | ... end |
| 20 | hey | three | xyz | unit | right | ... end |
+-----+-------+--------+-------+--------+--------+---------+
any help would be great!
This Code should help you...
Sub GetOutput()
Dim rndData As Range
Dim rngOutCell As Range
Dim MainIindex As Integer '<< Column index Needs to be split
Dim AllData As Variant '<< Data Range
Dim InnerData As Variant '<< Split Data
Dim intRecordCounter As Integer
MainIindex = 3
lngDataRow = 0
Set rndData = Sheet1.Range("E1").CurrentRegion
Set rngOutCell = Sheet1.Range("O1")
For intRecordCounter = 1 To rndData.Rows.Count
AllData = rndData.Rows(intRecordCounter).Value
InnerData = Split(rndData.Rows(intRecordCounter).Cells(MainIindex).Value, ",")
Set rngOutCell = Sheet1.Cells(Rows.Count, rngOutCell.Column).End(xlUp)
If rngOutCell <> vbNullString Then
Set rngOutCell = rngOutCell.Offset(1)
End If
Set rngOutCell = rngOutCell.Resize(UBound(InnerData) + 1, UBound(AllData, 2))
rngOutCell.Value = AllData
rngOutCell.Offset(, MainIindex - 1).Resize(, 1).Value = Application.Transpose(InnerData)
Next intRecordCounter
ClearMemory:
MainIindex = Empty
If IsArray(AllData) Then Erase AllData
If IsArray(InnerData) Then Erase InnerData
intRecordCounter = Empty
Set rndData = Nothing
Set rngOutCell = Nothing
End Sub