Pasting Data for samples based on their Test and ID - excel

I have a data sheet with Sample IDs, Test type, and Test results all in three separate columns(A,B,C).
Some samples IDs are listed multiple times, as they all receive different tests.
The three columns of Sample IDs, Test Type, and Test Results are on Sheet 1.
I paste the Sample ID son sheet 2 (only one iteration of each) down column A, and the test types across Row 1.
How do I paste the individual test result data in the correct position on the sheet?
Example: Sample 1 is the Y value and Test-type 1 is the Y axis.
I need to copy the test results and paste them according to sample ID and test type on another sheet.
Every time this workbook is to be used, the sample IDs and test type will change.
This is the code to paste the Sample IDs down Column A on Sheet2 and Test Type across row 1 on sheet 2.
Sub Transpose1()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim wkb1 As Workbook
Set wkb1 = ThisWorkbook
Set sht1 = wkb1.Sheets("Raw Data")
'Where the data is stored
Set sht2 = wkb1.Sheets("TestResultTable")
'This is where everything is to be pasted
sht2.Range("B2:Z4200").ClearContents
sht1.Range("A1:A4200").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht2.Range( _
"A1"), Unique:=True
'Sample IDs pasted with only one iteration of each sample
sht1.Range("B1:B4200").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht2.Range( _
"B2"), Unique:=True
'Test Type pasted on sheet2 to be copied again and pasted horizontally
sht2.Range("B3:B4200").Copy
sht2.Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
sht2.Range("B2:B4200").ClearContents
'The Test results are in sht1 column C
End Sub
The results will not be this organized and A,B,C,D etc. This was to hide proprietary information.
Screenshot of example data and format

A Basic VBA Pivot
Sub BasicPivot()
' s - Source (read from)
Const sName As String = "Raw Data"
Const sFirstCellAddress As String = "A1"
Const srCol As Long = 1
Const scCol As Long = 2
Const svCol As Long = 3
' d - Destination (write to)
Const dName As String = "TestResultTable"
Const dFirstCellAddress As String = "A1"
Const dFirstColumnHeader As String = ""
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' 1.) Write the source data to an array.
' a) Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
' b) Reference the source range.
Dim srg As Range: Set srg = sws.Range(sFirstCellAddress).CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
' c.) Write the values from the source range to an array.
Dim sData As Variant: sData = srg.Value
' 2.) Use dictionaries to get the unique row and column labels.
' a) Define the row dictionary.
Dim rDict As Object: Set rDict = CreateObject("Scripting.Dictionary")
rDict.CompareMode = vbTextCompare
Dim dr As Long: dr = 1
' b) Define the column dictionary.
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
cDict.CompareMode = vbTextCompare
Dim dc As Long: dc = 1
' c) Loop through the rows of the array and write the unique
' row and column labels to the dictionaries.
Dim Key As Variant
Dim sr As Long
For sr = 2 To srCount
Key = sData(sr, srCol)
If Not rDict.Exists(Key) Then
dr = dr + 1
rDict(Key) = dr
End If
Key = sData(sr, scCol)
If Not cDict.Exists(Key) Then
dc = dc + 1
cDict(Key) = dc
End If
Next sr
' 3.) Write the result to an array.
' a) Define the array.
Dim drCount As Long: drCount = rDict.Count + 1
Dim dcCount As Long: dcCount = cDict.Count + 1
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' b) Write the first column header.
Dim dfHeader As String
If Len(dFirstColumnHeader) = 0 Then
dfHeader = CStr(srg.Cells(1).Value)
Else
dfHeader = dFirstColumnHeader
End If
dData(1, 1) = dfHeader
' c) Write the row labels.
dr = 1
For Each Key In rDict.Keys
dr = dr + 1
dData(dr, 1) = Key
Next Key
' d) Write the column labels.
dc = 1
For Each Key In cDict.Keys
dc = dc + 1
dData(1, dc) = Key
Next Key
' e) Write the values.
For sr = 2 To srCount
dData(rDict(sData(sr, srCol)), cDict(sData(sr, scCol))) _
= sData(sr, svCol)
Next sr
' 4.) Write the results to the destination.
' a) Reference the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' b) Clear its cells.
dws.UsedRange.Clear
' c) Write the values from the array to the destination range.
With dws.Range(dFirstCellAddress).Resize(, dcCount)
.Resize(drCount).Value = dData
End With
' 5.) Inform.
MsgBox "Pivot has finished.", vbInformation
End Sub

Related

Suggestions for optimizing code that sorts data into multiple sheets - needs to be faster for 100k+ rows

How could I make my code faster...? I tried two different approaches to achieve what I need to, but they are rather slow when I work with ~140,000 rows of data.
The data is found in one sheet, and four additional sheets exist which have the names
LogName(1) = "Log_1"
LogName(2) = "Log_2"
LogName(3) = "Log_3"
LogName(4) = "Custom_Log"
LogNameSz = UBound(LogName) - LBound(LogName) + 1
Each data row contain one of these labels per row, and all of these labels are in the same column (see example below):
enter image description here
The spirit of the code is the following: for each row, look at the row's label, copy the entire row of data, and paste it into the sheet with the corresponding name.
These are my approaches:
''FIRST METHOD
'For j = 1 To LogNameSz
' cnt = 4
' Set celE = ColLog.Find(LogName(j), LookIn:=xlValues)
' fstadd = celE.Address
' 'Debug.Print fstadd
' Do
' celE.EntireRow.Copy Worksheets(LogName(j)).Rows(cnt)
' Set celE = ColLog.FindNext(celE)
' cnt = cnt + 1
' Loop While celE.Address <> fstadd
'Next j
''SECOND METHOD
' For s = 1 To Lastrworig
' If CkList(ColLog.Rows(s).Value, LogName, LogNameSz) = True Then
' Set ColEValue = Worksheets(ColLog.Rows(s).Value).UsedRange
' Lastrwlog = ColEValue.Row + ColEValue.Rows.count - 1
' ColLog.Rows(s).EntireRow.Copy Worksheets(ColLog.Rows(s).Value).Rows(Lastrwlog + 1)
' End If
' Next s
The reason why cnt = 4 is because the four additional sheets have 3 rows that have been added to the top of the sheets, and the data needs to be pasted starting on the 4th row. This is also the same reason why I look for the last row of each sheet by using UsedRange in my second method.
Does anyone one have suggestions for how to make either of these methods faster?
Copy +100k Criteria Rows
Sub CopyData()
Const SRC_NAME As String = "Master"
Const SRC_CRITERIA_COLUMN As Long = 5
Const SRC_FIRST_CELL As String = "A2"
Const DST_FIRST_CELL As String = "A4"
Dim dNames(): dNames = VBA.Array("Log_1", "Log_2", "Log_3", "Custom_Log")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range
With sws.UsedRange
Set srg = sws.Range(SRC_FIRST_CELL, .Cells(.Rows.Count, .Columns.Count))
End With
Dim cCount As Long: cCount = srg.Columns.Count
Dim sData(): sData = srg.Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim dKey
For Each dKey In dNames
Set dict(dKey) = New Collection
Next dKey
Erase dNames
Dim sr As Long, srString As String
For sr = 1 To UBound(sData, 1)
srString = CStr(sData(sr, SRC_CRITERIA_COLUMN))
If dict.Exists(srString) Then dict(srString).Add sr
Next sr
Dim dws As Worksheet, dData(), srItem, dr As Long, c As Long
For Each dKey In dict.Keys
ReDim dData(1 To dict(dKey).Count, 1 To cCount)
dr = 0
For Each srItem In dict(dKey)
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = sData(srItem, c)
Next c
Next srItem
Set dws = wb.Sheets(dKey)
dws.Range(DST_FIRST_CELL).Resize(dr, cCount).Value = dData
Next dKey
MsgBox "Data copied.", vbInformation
End Sub

Filter Column based on a value inside the cells

I'm a VBA noob. I need help working out this filter:
My data has ~50,000 rows and 100 columns. The column I want to filter has values like TL-98.263138472% BD-1.736861528%. I want to filter out all the values in VBA where TL>90%. I can think of a long way of doing it - where I create a loop, break down each cell, then look at TL, then the 4 numbers next to it. But it sounds like it would take forever. Wondering if there's a faster/easier way to do it? Also wondering, if it's even worth it. If it would take even more than 2 seconds, then I would rather not do it with VBA.
I have not coded it yet, wanted to see if anyone has better ideas than what I came up with.
Thanks in advance! Adding an example of my data below:
Pretty fast in my tests:
Sub tester()
Dim ws As Worksheet, t
Dim i As Long, rng As Range, rngFilt As Range, arr, arrFilt
' For i = 2 To 50000 'create some dummy data
' Cells(i, "A") = "TL-" & 50 + (Rnd() * 60) & "% BD-1.736861528%"
' Next i
' [B2:CV50000].value="blah" 'fill rest of table
t = Timer
Set ws = ActiveSheet
If ws.FilterMode Then ws.ShowAllData
Set rng = ws.Range("A1:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row) 'range of values to filter
Set rngFilt = rng.Offset(0, 110) 'a range off to the right to filter on
arr = rng.Value
arrFilt = rngFilt.Value 'for holding filtering flags
arrFilt(1, 1) = "Filter" 'column header
For i = 2 To UBound(arr, 1)
arrFilt(i, 1) = IIf(FilterOut(arr(i, 1)), "Y", "N")
Next i
rngFilt.Value = arrFilt
rngFilt.AutoFilter field:=1, Criteria1:="N"
Debug.Print Timer - t
End Sub
'does this value need to be filtered out?
Function FilterOut(v) As Boolean
Dim pos As Long
pos = InStr(v, "TL-")
If pos > 0 Then
v = Mid(v, pos + 3)
pos = InStr(v, "%")
If pos > 0 Then
v = Left(v, pos - 1)
'Debug.Print v
If IsNumeric(v) Then FilterOut = v > 90
End If
End If
End Function
This ran in <0.3 sec for me, on a 50k row X 100 col dataset
Filter Via Table Helper Column and String Parse
It you want to look into non VBA solutions, You could use a helper column to decide it it's worth filtering out.
First we need to find "TL-" in the string, then find "%" After that:
MID(A4,FIND("TL-",A4)+3,FIND("%",A4,FIND("TL-",A4)+3)-FIND("TL-",A4)-3)
This will just return us that value sub string, regardless or position.
Now we need to convert it into a value... and I'm told that --( ) isn't the correct way to convert a string to a value... but i keep using it and it keeps working.
Anyway, finally we test if that is larger than 90 like:
=IF(--(MID(A4,FIND("TL-",A4)+3,FIND("%",A4,FIND("TL-",A4)+3)-FIND("TL-",A4)-3))>90,"Remove","Keep")
Here's my example:
And the final result.
And Filtered:
Copy Values (Efficiently!?)
The Code
Option Explicit
Sub CopyData()
Dim T As Double: T = Timer
' Read Data: Write the values from the source range to an array.
' Define constants.
Const SRC_NAME As String = "Sheet1"
Const SRC_COLUMN As Long = 44
Const CRIT_STRING_LEFT As String = "TL-"
Const CRIT_VALUE_GT As Double = 90
Const DST_NAME As String = "Sheet2"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range.
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
Dim cCount As Long: cCount = srg.Columns.Count
' Write to the array (practically this line uses up all the time).
Dim Data(): Data = srg.Value ' assumes at least two cells in 'srg'
Debug.Print "Read Data: " & Format(Timer - T, "0.000s")
T = Timer
' Modify Data: Write the critical values to the top of the array.
Dim cLen As Long: cLen = Len(CRIT_STRING_LEFT)
Dim dr As Long: dr = 1 ' skip headers
Dim sr As Long, c As Long
Dim cPos As Long, cNum As Double, cString As String
For sr = 2 To srCount ' skip headers
cString = CStr(Data(sr, SRC_COLUMN))
cPos = InStr(1, cString, CRIT_STRING_LEFT, vbTextCompare)
If cPos > 0 Then
cString = Right(cString, Len(cString) - cPos - cLen + 1)
cString = Replace(cString, "%", "")
cNum = Val(cString) ' 'Val' doesn't work with "!,#,#,$,%,&,^"
If cNum > CRIT_VALUE_GT Then ' 'Evaluate' is too slow!
dr = dr + 1
For c = 1 To cCount
Data(dr, c) = Data(sr, c)
Next c
End If
End If
Next sr
Debug.Print "Modify Data: " & Format(Timer - T, "0.000s")
T = Timer
' Write Data: Write the values from the array to the destination range.
If dr = 0 Then Exit Sub ' no filtered values
' Reference the destination range.
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim drg As Range: Set drg = dws.Range("A1").Resize(dr, cCount)
' Write to the range (practically this line uses up all the time).
drg.Value = Data
' Clear below
drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
Debug.Print "Write Data: " & Format(Timer - T, "0.000s")
MsgBox "Data copied.", vbInformation
End Sub
The Result (Time Passed)
On a sample of 50k rows by 100 columns of data with 26k matches, the code finished in under 5s:
Read Data: 1.336s
Modify Data: 0.277s
Write Data: 3.375s
There were no blank cells and each cell in the criteria column contained the criteria string with a percentage hence it should be faster on your data. Your feedback is expected.

Defining the end of the Range with last cell with a value instead of the row number

I use two data dumps which are saved in OPL_Dump and OPL_DUMP_2 sheets.
The code I am trying to improve, finds the data in one of the dumps and copies and pastes as a new parameter as addition to the same corresponding value it sees for the other dump.
The length of both the data dumps varies. I manually amend the length of the range every time.
I am trying to make my code a bit more robust
I tried defining N and L instead of fixed numbers of last rows.
Sub Merging_Both_Dumps_for_Product_Type()
Dim out() As String
'Dim out2() As String
L As Long
L = ThisWorkbook.Sheets("OPL_DUMP_2").Select.Cells(Rows.Count, "B").End(xlUp).Row
ThisWorkbook.Sheets("OPL_DUMP_2").Select
keyarray = Range("F" & 2 & ":F" & L)
valuearray = Range("J" & 2 & ":J" & L)
N As Long
N = ThisWorkbook.Sheets("OPL_DUMP").Select.Cells(Rows.Count, "B").End(xlUp).Row
ReDim out(N, 0)
For j = 2 To N
ind = Index(keyarray, ThisWorkbook.Sheets("OPL_DUMP").Cells(j, 2).Value)
out(j - 2, 0) = valuearray(ind, 1)
Next j
'ReDim out2(1, 0)
'out2(1, 0) = "test"
'ThisWorkbook.Sheets("OPL_DUMP").Range("AD2:AD3") = out2()
ThisWorkbook.Sheets("OPL_DUMP").Range("AC" & 2 & ":AC" & N) = out
End Sub
Try this code, should work fine, fast and always no matter the size of your dumps:
Option Explicit
Sub Merging_Both_Dumps_for_Product_Type()
'You need the reference Microsoft Scripting Runtime
'under tools-references activated for this code to work.
Dim output_values As Dictionary
Set output_values = load_output_values(ThisWorkbook.Sheets("OPL_DUMP_2").UsedRange.Value)
'Store your output worksheet inside an array
Dim arr As Variant: arr = ThisWorkbook.Sheets("OPL_DUMP").UsedRange.Value
'loop through the array
Dim i As Long
For i = 2 To UBound(arr)
'check if the value in col B exists in the dictionary
If output_values.Exists(arr(i, 2)) Then
arr(i, 29) = output_values(arr(i, 2))
End If
Next i
'paste back the array to the worksheet
ThisWorkbook.Sheets("OPL_DUMP").UsedRange.Value = arr
'Note that using worksheet.usedrange.value will store
'everything in the sheet that has been used, even if its blank
'meaning if you do ctrl+end in your keyboard, the array will be
'as big as A1: the cell where ctrl+end sends you.
End Sub
Private Function load_output_values(arr As Variant) As Dictionary
'this function will store in a dictionary each key (col F = index 2)
'with it's item (col J = index 10)
'Since we stored the sheet inside an array we can loop through it
Set load_output_values = New Dictionary ' init the dictionary
Dim i As Long
For i = 2 To UBound(arr)
'first check either column B is empty or already exists
'will take the first ocurrence if col B is duplicated.
If Not arr(i, 2) = vbNullString _
And Not load_output_values.Exists(arr(i, 2)) Then
load_output_values.Add arr(i, 2), arr(i, 10)
End If
Next i
End Function
Lookup Data Using Application.Match
Option Explicit
Sub LookupData()
' 1. Define constants.
' Source
Const sName As String = "OPL_DUMP_2"
Const skCol As String = "F" ' 2. ... lookup the key...
Const svCol As String = "J" ' 3. ... read the associated value...
Const sfRow As Long = 2
' Destination
Const dName As String = "OPL_DUMP"
Const dkCol As String = "B" ' 1. Read the key...
Const dvCol As String = "AC" ' 4. ... write the value.
Const dfRow As Long = 2
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' 2. Reference the source key (one-column) range ('skrg')
' and write the values from the source value (one-column) range ('svrg')
' to a 2D one-based (one-column) array ('svData').
' We will use 'skrg' because 'Application.Match' is faster on a range.
' We will use 'svData' because reading from an array is faster than
' from a range.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, skCol).End(xlUp).Row
Dim srCount As Long: srCount = slRow - sfRow + 1
If srCount < 1 Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
Dim skrg As Range: Set skrg = sws.Cells(sfRow, skCol).Resize(srCount)
' ... which is the same as:
'Set skrg = sws.Range(sws.Cells(sfRow, skCol), sws.Cells(slrow, skCol))
Dim svrg As Range: Set svrg = skrg.EntireRow.Columns(svCol)
Dim svData() As Variant
If srCount = 1 Then ' one cell
ReDim svData(1 To 1, 1 To 1): svData(1, 1) = svrg.Value
Else ' multiple cells
svData = svrg.Value
End If
' 3. Reference the destination key (one-column) range ('skrg')
' and write its values the to a 2D one-based (one-column) array,
' the destination keys array ('dkData').
' We will use 'dkData' because reading from an array is faster than
' from a range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dkCol).End(xlUp).Row
Dim drCount As Long: drCount = dlRow - dfRow + 1
If drCount < 1 Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
Dim dkrg As Range: Set dkrg = dws.Cells(dfRow, dkCol).Resize(drCount)
' ... which is the same as:
'Set dkrg = dws.Range(dws.Cells(dfRow, dkCol), dws.Cells(dlrow, dkCol))
Dim dkData() As Variant
If drCount = 1 Then ' one cell
ReDim dkData(1 To 1, 1 To 1): dkData(1, 1) = dkrg.Value
Else ' multiple cells
dkData = dkrg.Value
End If
' 3. Write the matching values to the destination values array ('dvData'),
' a 2D one-based one-column array, with the same number of rows
' as the number of rows of the destination keys array.
Dim dvData() As Variant: ReDim dvData(1 To drCount, 1 To 1)
Dim sr As Variant
Dim dValue As Variant
Dim dr As Long
For dr = 1 To drCount
dValue = dkData(dr, 1)
sr = Application.Match(dValue, skrg, 0)
If IsNumeric(sr) Then ' is a number (the row index)
dvData(dr, 1) = svData(sr, 1)
'Else ' is an error value (no match); do nothing
End If
Next dr
' 4. Write the values from the destination values array
' to the destination values range ('dvrg').
Dim dvrg As Range: Set dvrg = dkrg.EntireRow.Columns(dvCol)
dvrg.Value = dvData
' Save the workbook.
'wb.Save
' 5. Inform.
MsgBox "Lookup has finished.", vbInformation
End Sub

Unpivoting 2 categories of columns using vba

I have code that unpivots columns with the category of Line1, Line2, Line3, Line4 into one Column called Lines. This code accomplishes that goal. However, I also have other another category I want to unpivot as well but I'm not sure how to unpivot two categories at the same time. My code only unpivots one category. I want it to unpivot two: Line1, Line2, Line3, Line4 & Color1, Color2, Color3, Color4 -----> Unit Name & Color (each with their own columns). Very hard to explain, so I have attached my code and also a few tables pictures. The 2nd pic is how I want to look. As I stated before, the code works to unpivot Columns H-K (s/o to VBasic 2008 for the help last time), but I also want to unpivot Columns N-Q as well. Any help or suggestions will be greatly appreciated. Keep in mind I tried using the table function on here but it doesn't work very well for me due to the size of my data so apologies for the inconvenience. I will gladly upvote your responses if you help me.
Option Explicit
Sub TransformData()
' 1. Define constants (the arrays obviously aren't constants).
' s - source (read from)
' sd - source data (no headers)
' d - destination (write to)
' r - row
' c - column
' u - unpivot (columns)
' v - value (columns)
' Source
Const sName As String = "Sheet1"
' These columns will be unpivoted...
Dim suCols() As Variant: suCols = VBA.Array(8, 9, 10, 11)
' ... while these columns will be just copied except for the 0 column...
Dim svCols() As Variant: svCols = VBA.Array(12, 4, 0, 5, 6, 2, 3, 13, 14, 15, 16, 17)
' which is a 'place holder' for the pivot column.
' The 'svCols' array 'tells' that column 12 will be written to column 1,
' column 4 will be written to column 2, the unpivot columns will be written
' to column 3, ... etc.
' Destination
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A1"
Const duTitle As String = "Unit Name"
' 2. Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' 3. Reference the source worksheet ('sws'), the source range ('srg')
' and the source data range ('sdrg'). Also, write the number of rows
' of each of the ranges to variables ('srCount', 'sdrCount')
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' has headers
Dim srCount As Long: srCount = srg.Rows.Count ' incl. headers
Dim sdrCount As Long: sdrCount = srCount - 1 ' excl. headers
Dim sdrg As Range: Set sdrg = srg.Resize(sdrCount).Offset(1) ' no headers
' 4. The Number of Destination Rows and Columns
' Determine the number of destination rows ('drCount').
Dim suUpper As Long: suUpper = UBound(suCols) ' represents the highest index number with suCols
Dim drCount As Long: drCount = 1 ' headers
Dim su As Long
For su = 0 To suUpper
drCount = drCount + sdrCount _
- Application.CountBlank(sdrg.Columns(suCols(su)))
Next su
' Determine the number of destination columns ('dcCount').
Dim svUpper As Long: svUpper = UBound(svCols)
Dim dcCount As Long: dcCount = svUpper + 1
' 5. The 2D One-Based Arrays
' Write the values from the source range to an array ('sData').
Dim sData As Variant: sData = srg.Value
' Define the destination array ('dData').
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' 6. Write the values from the source array to the destination array.
' Write headers.
Dim sValue As Variant
Dim sv As Long
For sv = 0 To svUpper
If svCols(sv) = 0 Then ' unpivot
sValue = duTitle
Else ' value
sValue = sData(1, svCols(sv))
End If
dData(1, sv + 1) = sValue
Next sv
' Write data.
Dim dr As Long: dr = 1 ' headers are already written
Dim sr As Long
For sr = 2 To srCount
For su = 0 To suUpper
sValue = sData(sr, suCols(su))
If Not IsEmpty(sValue) Then
dr = dr + 1
For sv = 0 To svUpper
If svCols(sv) = 0 Then ' unpivot
sValue = sData(sr, suCols(su))
Else ' value
sValue = sData(sr, svCols(sv))
End If
dData(dr, sv + 1) = sValue
Next sv
End If
Next su
Next sr
' 7. Write the results to the destination worksheet.
' Reference the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Clear previous data.
dws.Cells.Clear
' Write the new values.
With dws.Range(dFirstCellAddress).Resize(, dcCount)
' Write the values from the destination array
' to the destination worksheet.
.Resize(drCount).Value = dData
' Apply simple formatting:
' Headers.
.Font.Bold = True
' Entire Columns
.EntireColumn.AutoFit
End With
' Save the workbook.
'wb.Save
' 8. Inform to not wonder if the code has run or not.
MsgBox "Data transformed.", vbInformation
End Sub
Sub test()
Dim sh1 As Worksheet: Dim sh2 As Worksheet: Dim hdr
Dim rgUnit As Range: Dim rgColor As Range: Dim cell As Range
Dim i As Long: Dim cnt As Long: Dim r As Long: Dim arr
'setting the sheet into variable - change if needed
Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")
'clear all cells in sh2
sh2.Cells.ClearContents
'the header which will be in sh2 coming from sh1 header as hdr variable
hdr = Array("Family", "Company Name", "Unit 1 name", "Unit 2 Name", "Unit 3 Name", "Unit 4 Name", "First Name", "Last Name", "Status", "Email", "Phone", "Color 1", "Color 2", "Color 3", "Color 4")
'put the data from sh1 to sh2 according to the header name defined in arr
For i = LBound(hdr) To UBound(hdr)
sh1.Columns(sh1.Rows(1).Find(hdr(i)).Column).Copy Destination:=sh2.Columns(i + 1)
Next
'start row
r = 2
Do
'set the range for Unit Name and Color according to the looped row into variable rgUnit and rgColor
Set rgUnit = sh2.Range(sh2.Cells(r, 3), sh2.Cells(r, 6))
Set rgColor = rgUnit.Offset(0, 9)
'count how many data in rgUnit as cnt variable
cnt = Application.CountA(rgUnit)
'if cnt > 1, copy the looped row then insert under it as many as cnt - 1
If cnt > 1 Then
sh2.Rows(r).Copy
sh2.Rows(r + 1 & ":" & r + cnt - 1).Insert Shift:=xlDown
Application.CutCopyMode = False
End If
'fill the unit name
Set arr = CreateObject("scripting.dictionary")
For Each cell In rgUnit.SpecialCells(xlCellTypeConstants): arr.Item(cell.Value) = 1: Next
rgUnit.Resize(cnt, 1).Value = Application.Transpose(arr.keys)
'fill the color
Set arr = CreateObject("scripting.dictionary")
For Each cell In rgColor.SpecialCells(xlCellTypeConstants): arr.Item(cell.Value) = 1: Next
rgColor.Resize(cnt, 1).Value = Application.Transpose(arr.keys)
'increase the row value by add the cnt value
r = r + cnt
Loop Until Application.CountA(sh2.Range(sh2.Cells(r, 3), sh2.Cells(r, 6))) = 0 'finish the loop when rgUnit has no data
'delete unneeded column
rgUnit.Resize(rgUnit.Rows.Count, 3).Offset(0, 1).EntireColumn.Delete
rgColor.Resize(rgColor.Rows.Count, 3).Offset(0, 1).EntireColumn.Delete
'give the correct name for unit and color header in sh2
sh2.Range("C1").Value = "Unit Name"
sh2.Range("i1").Value = "Color"
End Sub
The sub assumed :
each person name at lease has one unit
if he has one unit name then he has one color , if he has two unit name then he has two colors, and so on.
each item in the hdr variable is exactly the same string which is in sheet1 header.
The process is explained in the commented line of the sub.
While in Sheet2, please step run the code and see what happen to the sheet when it step the line.
if the line Set arr = CreateObject("scripting.dictionary") throw you an error, please try the substitute code below:
'fill the unit name
Set rgFill = rgUnit.Resize(1, 1)
For Each cell In rgUnit.SpecialCells(xlCellTypeConstants)
rgFill.Value = cell.Value
Set rgFill = rgFill.Offset(1, 0)
Next
'fill the color
Set rgFill = rgColor.Resize(1, 1)
For Each cell In rgColor.SpecialCells(xlCellTypeConstants)
rgFill.Value = cell.Value
Set rgFill = rgFill.Offset(1, 0)
Next
And change the dim arr to dim rgFill as range

Store and Paste values with a dynamic array

first of all sorry for my bad english, it's not my native lang.
i have a dynamic table that changes its content when i insert a specific keynumber
The keynumber in this case is "5" and all the content of that sheet changes according to the number i enter (from 1 to 42).
What i want to do is copy all the data and paste only the values in an empty row on the same sheet.
i achieved that with the next code:
Sheets("Biblia General").Range("B8:H142").Copy
Sheets("Biblia General").Range("M8").PasteSpecial xlPasteValues
'Remove the animation around the copied cell
Application.CutCopyMode = False
Selection.Sort key1:=Range("N8")
when i press the button copiar it copies and then paste on the right of the sheet.
But now i need to do the same thing but for the whole keynumbers, for example i need to run a copy and paste of the values of all the tables for 1 to 42 not just one by one.
i don't know how to enter for example the keynumber 1 calculate the sheet then copy the content and paste the values to the right, then do it again but for keynumber 2 and so on until it ends at keynumber 42...
is there a way i can achieve that? im not realy familiar with vba but i think i need to do a dynamic array or something like that
thanks in advance
Copy Values by Assignment
When you do drg.Value = srg.Value, it is as fast as you can copy values (not formulas or formats). It is called Copying by Assignment and there is one simple rule: both ranges have to be of the same size (same number of rows and columns).
Usually, you only know the first cell of the destination range and you know it has to be of the size of the source range. Let's call the first cell dfCell. To create a reference to the destination range you will do the following:
Dim drg As Range: Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
The Code
Option Explicit
Sub CopyData()
Const wsName As String = "Biblia General"
Const ClaveCount As Long = 42
Const ClaveAddress As String = "C1" ' Clave
Const LoteAddress As String = "C3" ' Lote
Const srgAddress As String = "B8:H142"
Const dfCellAddress As String = "M8"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim srg As Range: Set srg = ws.Range(srgAddress)
Dim Clave As Range: Set Clave = ws.Range(ClaveAddress)
Dim Lote As Range: Set Lote = ws.Range(LoteAddress)
Dim rCount As Long: rCount = srg.Rows.Count
Dim cCount As Long: cCount = srg.Columns.Count
Dim dfCell As Range: Set dfCell = ws.Range(dfCellAddress)
Application.ScreenUpdating = False
dfCell.Offset(, -1).Resize(ws.Rows.Count - dfCell.Row + 1, cCount + 1) _
.ClearContents
Dim drg As Range
Dim dclrrg As Range
Dim n As Long
For n = 1 To ClaveCount
Clave.Value = n
Set drg = dfCell.Resize(rCount, cCount)
drg.Value = srg.Value
If n = 1 Then
drg.Cells(1).Offset(, -1).Value = "Lote" ' Lote
' exclude headers
rCount = rCount - 1
Set srg = srg.Resize(rCount).Offset(1)
Set drg = drg.Resize(rCount).Offset(1)
End If
drg.Columns(1).Offset(, -1).Value = Lote.Value ' Lote
drg.Sort drg.Columns(2), xlAscending, , , , , , xlNo
Set dfCell = drg.Columns(2) _
.Find("*", , xlValues, , , xlPrevious).Offset(1, -1)
Set dclrrg = drg.Resize(drg.Row + rCount - dfCell.Row) _
.Offset(dfCell.Row - drg.Row, -1).Resize(, cCount + 1)
dclrrg.ClearContents
Next n
Application.ScreenUpdating = True
MsgBox "Data copied.", vbInformation, "CopyData"
End Sub
I think it is easier without an array:
Dim i As Long
For i = 1 To 42
[D1].Value = i 'set the key number (please check the address
Sheets("Biblia General").Range("B8:H142").Copy '135 rows
'Paste each block below the previous one
Sheets("Biblia General").Range("M8").Offset((i - 1) * 135, 0).PasteSpecial xlPasteValues
'Remove the animation around the copied cell
Application.CutCopyMode = False
Selection.Sort key1:=Range("N8")
Next i

Resources