Related
I am working on a report and trying to output my data like this
Input:
Output
I am thinking of using a dictionary with each key has multiple value of Items&their but i don't know how to implement.
Using a dictionary would not work for your chart example. A dictionary is used to hold ONLY TWO string values using a hashtable. An example of using a dictionary properly is using the two words "hello" and "a polite greeting to another human". The first string is for the word and the second is the definition of the word, just like a regular dictionary.
I would provide you with two better options. You could create a 2D array which holds all your values, but you would need to output the labels separately from the values. You could also create a file which holds the labels and the values for your chart.
If you need more help, please provide more information on what you are trying to do with the chart displayed. An array is better for calculations but a file is better for storing the values and displaying the chart.
Second answer would be to use a dictionary of dictionaries. Again input data is
With the following code
Sub DemoDictOfDict()
Dim rg As Range, rgHdr As Range
Dim dict As Dictionary
Dim sngDict As Dictionary
Dim wkb As Workbook, wks As Worksheet
Set wkb = ActiveWorkbook
Set wks = wkb.ActiveSheet
Set rg = wks.Range("A1").CurrentRegion
' Retrieving the header line from the data
Set rgHdr = rg.Rows(1).Offset(, 1).Resize(, rg.Columns.Count - 1)
Dim vHdr As Variant
vHdr = rgHdr.Value
Dim sngRow As Range
Dim sngCell As Range
Dim vdat As Variant
Dim k As Long
' Creating the dictionary which will be used
' to hold the dictionaries with the data
Set dict = New Dictionary
' Looping through the rows of the data
' as we are not using the listobject one has to use offset and resizte
For Each sngRow In rg.Offset(1).Resize(rg.Rows.Count - 1).Rows
' getting the number for different columns
' again listobject not used, so working with resizte and offset
vdat = sngRow.Offset(, 1).Resize(, sngRow.Columns.Count - 1)
' Creating the dictionary containing the numbers
Set sngDict = New Dictionary
For k = LBound(vHdr, 2) To UBound(vHdr, 2)
' Adding the values to the "inner" dictionary
sngDict.Add vHdr(1, k), vdat(1, k)
Next k
' Adding the dictionary to the dictionary
Set dict(sngRow.Cells(1, 1).Value) = sngDict
Next
' output to immediate windows
Dim outName As String, vDict As Dictionary
Dim key As Variant, i As Long
For i = 0 To dict.Count - 1
outName = dict.Keys(i)
Set vDict = dict.Items(i)
Debug.Print outName
For Each key In vDict.Keys
Debug.Print key, vDict(key)
Next
Next i
End Sub
you get the following output in the immediate window
First answer as said in one of my comments you could use Power Query to unpivot the data. As example data I took data like this
After unpivoting the data with PowerQuery (goto Data then From Table/Range, select the columns with Apple, Orange etc. in the Power Query Editor, select the tab Transform and there Unpivot columns) one gets
Then you pivot the data again and you get
Unless you're going to do something else with the collected data then there's no need for any intermediate data structure:
Dim data, r As Long, c As Long
data = ActiveSheet.Range("A3:D5").Value
For r = 2 To UBound(data, 1)
Debug.Print data(r, 1)
For c = 2 To UBound(data, 2)
Debug.Print data(1, c) & " " & data(r, c)
Next c
Debug.Print "Checked."
Next r
The location of the data should be the same as the picture to work.
Sub test()
Dim vDB As Variant
Dim vR() As Variant
Dim i As Long, r As Long, n As Long
Dim c As Integer, j As Integer
vDB = Range("a3").CurrentRegion
r = UBound(vDB, 1)
c = UBound(vDB, 2)
For i = 3 To r
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = vDB(i, 1)
For j = 2 To c
n = n + 1
ReDim Preserve vR(1 To n)
If vDB(i, j) = "" Then
vR(n) = "Checked"
Else
vR(n) = vDB(2, j) & Space(1) & vDB(i, j)
End If
Next j
Next i
Sheets.Add
Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
End Sub
Result Sheet
Excel macro 2016 in VBA. Need to copy from 8 separated columns from one sheet to another, in different order. Tried but the Paste is done always in same column A...
Code starts with:
Sub Button1_Click()
Dim ultima_fila As Long
Dim rango, columna As String
Sheets("Validation by rules").Select
ultima_fila = Cells(Rows.Count, 1).End(xlUp).Row
' TableName
columna = "A"
rango = columna & "1:" & columna & CStr(ultima_fila)
MsgBox rango
range(rango).Copy
Sheets("TMP").Paste
'TableField
columna = "B"
rango = columna & "1:" & columna & CStr(ultima_fila)
MsgBox rango
range(rango).Copy
Sheets("TMP").Paste
However, I don't know how to tell the macro to paste the second time into B...? or any other btw...
Also, tried a For loop with no success to avoid copy/paste my code... something like:
For X in (A,B,C,F,G,R,S,T)
No luck either...
Thanks a lot!
You are not telling the code where to paste with: Sheets("TMP").Paste. You only name the sheet but not the column.
Also use a loop so you do not need to keep retyping the same thing:
Sub Button1_Click()
Dim ultima_fila As Long
Dim columnOrd As Variant
columnOrd = Array("A", "B", "C", "G", "F", "R", "S", "T")
With Sheets("Validation by rules")
ultima_fila = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 1 To 8
MsgBox .Range(.Cells(1, columnord(i - 1)), .Cells(ultima_fila, columnord(i - 1))).Address
.Range(.Cells(1, columnord(i - 1)), .Cells(ultima_fila, columnord(i - 1))).Copy Destination:=Sheets("TMP").Cells(1, i)
Next i
End With
End Sub
Use an array to collect, reshape then return the values.
A,B,C,G,F,R,S,T to sheet TMP in columns A,B,C,D,E,F,G,H
Sub Button1_Click()
Dim i As Long, arr as variant
with workSheets("Validation by rules")
'collect
i= .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .range(.cells(1,"A"), .cells(i, "T")).value
'reshape part 1
for i=lbound(arr, 1) to ubound(arr, 1)
arr(i, 4) = arr(i, 7)
arr(i, 5) = arr(i, 6)
arr(i, 6) = arr(i, 18)
arr(i, 7) = arr(i, 19)
arr(i, 8) = arr(i, 20)
next i
end with
'reshape part 2
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), lbound(arr, 2) to 8)
'return
workSheets("TMP").cells(1,1).resize(ubound(arr, 1), ubound(arr, 2)) = arr
end sub
I think that this code is self explanatory and easy to modify.
Sub Button1_Click()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Const CopyDataOnly As Boolean = False
Dim c As Long
Dim c1 As String, c2 As String
Dim source As Range, target As Range
With Sheets("Validation by rules")
For c = 0 To 7
c1 = Split("A,B,C,G,F,R,S,T", ",")(c)
c2 = Split("A,B,C,D,E,F,G,H", ",")(c)
Set source = .Range(.Cells(1, c1), .Cells(.Rows.Count, c1).End(xlUp))
Set target = Sheets("TMP").Cells(1, c2)
If CopyDataOnly Then
target.Resize(source.Rows.Count).Value = source.Value
Else
source.Copy target
End If
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Approach via Application.Index
This solution demonstrates relatively unknown possibilities of the Application.Index function and allows to restructure the whole array set in one single code line thus avoiding further loops or ReDim(cf. section [3]):
v = Application.Index(v, _
Application.Evaluate("row(1:" & n - FIRSTROW + 1 & ")"), _
a)
Calling procedure
Option Explicit ' declaration head of your code module
Sub CopyColumns()
' Purpose: copy defined columns to target sheet
Const FIRSTROW& = 2 ' <<~~ change to first data row
Dim i&, j&, n& ' row or column counters
Dim a, v ' variant arrays
Dim ws As Worksheet, ws2 As Worksheet ' declare and set fully qualified references
Set ws = ThisWorkbook.Worksheets("Validation by rules")
Set ws2 = ThisWorkbook.Worksheets("TMP")
' [1] Get data from A1:T{n}
n = ws.Range("A" & Rows.Count).End(xlUp).Row ' find last row number n
v = ws.Range("A" & FIRSTROW & ":T" & n) ' get data cols A:T and omit header row(s)
' [2] build columns array (type Long)
a = buildColAr("A,B,C,F,G,R,S,T") ' << get wanted column numbers via helper function
' [3] Column Filter A,B,C,F,G,R,S,T
v = Application.Index(v, _
Application.Evaluate("row(1:" & n - FIRSTROW + 1 & ")"), _
a) ' column array
' [4] Copy results array to target sheet, e.g. starting at A2
ws2.Range("A2").Offset(0, 0).Resize(UBound(v), UBound(v, 2)) = v
End Sub
Helper function buildColAr()
The helper function only offers some further convenience by translating the column names "A,B,C,F,G,R,S,T" to a numbered array 1|2|3|6|7|18|19|20 instead of counting the columns by yourself and assigning values directly, e.g. via parameter Array(1,2,3,6,7,18,19,20)
Function buildColAr(ByVal v As Variant) As Variant
' Purpose: return column number array from splitted string values
' Example: a = buildColAr("A,B,C,F,G,R,S,T") returns 1|2|3|6|7|18|19|20
Dim i&, temp
v = Split(v, ","): ReDim temp(LBound(v) To UBound(v))
For i = LBound(v) To UBound(v)
temp(i) = Cells(1, v(i)).Column ' get column numbers
Next i
buildColAr = temp
End Function
If:
Your data is stored in a file on disk (and not in-memory in an open Excel workbook with unsaved changes), and
You only want to copy and paste the data, not formatting
then you can read the relevant columns in the appropriate order into an ADODB Recordset, and then copy the recordset data into the destination using the CopyFromRecordset method.
Add a reference to Microsoft ActiveX Data Objects 6.1 Library (via Tools -> References...). There may be versions other than 6.1; choose the highest.
Then, you can use the following code:
Dim excelPath As String
excelPath = "C:\path\to\excel\file.xlsx" ' Replace with the path to the Excel file
Dim connectionString As String
connectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=""" & excelPath & """;" & _
"Extended Properties=""Excel 12.0;HDR=No"""
Dim sql As String
sql = _
"SELECT F1, F2, F3, F4, F6, F18, F19, F20 " & _
"FROM [Validation by rules$] "
' When setting the HDR=No option in the connection string, column names are
' automatically generated -- Column A -> F1, Column B -> F2 etc.
' If the first row of your column is the column header, you could specify HDR=Yes
' and use those column headers in SQL
Dim rs As New ADODB.Recordset
rs.Open sql, connectionString
Worksheets("TMP").Range("A1").CopyFromRecordset rs
I have a column with nearly 100k and am trying to determine how many times a value occurs repeatedly in that column. I can do it row by row currently, but this is menial as a programmer, through something like =COUNTIF(D:D,D2). Yet that only returns D2 matches in column D.
I need to iterate through all values of D returning countif, therefore revealing all of the values repetitions in the column. I can remove duplicates later! So I have a dev. button a basic sub, or function (man this is new to me) and something along the lines of the most basic for loop ever. Just getting caught up on how to implement the COUNTIF() to to the loop properly.
Right now I'm looking at:
Sub doloop()
Dim i As Integer
i = 1
Do While i < D.Length
Cells(i, 8).Value =CountIf(D:D,D[i])
i = i + 1
Loop
End Sub
That code is incorrect obviously but it is where I'm at and may help for anyone more familiar with other languages.
Use Application.WorksheetFunction.CountIf() in your loop.
Private Sub doloop()
Dim lastRow As Long
Dim d As Double
Dim r As Range
Dim WS As Excel.Worksheet
Dim strValue As String
Dim lRow As Long
'Build your worksheet object
Set WS = ActiveWorkbook.Sheets("sheet1")
'Get the last used row in column A
lastRow = WS.Cells(WS.Rows.count, "D").End(xlUp).Row
'Build your range object to be searched
Set r = WS.Range("D1:D" & lastRow)
lRow = 1
WS.Activate
'Loop through the rows and do the search
Do While lRow <= lastRow
'First, get the value we will search for from the current row
strValue = WS.Range("D" & lRow).Value
'Return the count from the CountIf() worksheet function
d = Application.worksheetFunction.CountIf(r, strValue)
'Write that value to the current row
WS.Range("H" & lRow).Value = d
lRow = lRow + 1
Loop
End Sub
I believe you are trying to write the value to the cell, that is what the above does. FYI, if you want to put a formula into the cell, here is how that is done. Use this in place of WS.Range("H" & lRow).Value = d
WS.Range("H" & lRow).Formula = "=CountIf(D:D, D" & lRow & ")"
Sounds like you may want to look into using tables in Excel and capitalizing on their features like filtering and equation autofill. You may also be interested in using a PivotTable to do something very similar to what you're describing.
If you really want to go about this the programmatic way, I think the solution Matt gives answers your question about how to do this using CountIf. There's a big detriment to using CountIf though, in that it's not very computationally efficient. I don't think the code Matt posted will really be practical for processing the 100K rows mentioned in the OP (Application.ScreenUpdating = false would help some). Here's an alternative method that's a lot more efficient, but less intuitive, so you'll have to decide what suites your needs and what you feel conformable with.
Sub CountOccurances()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("E1:E100000")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Overwrite original array values with count of that value
For i = 1 To UBound(A)
A(i, 1) = d(A(i, 1))
Next
'Write resulting array to output range
ROutput = A
End Sub
You can also modify this to include the removal of replicates you mentioned.
Sub CountOccurances_PrintOnce()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("F1:F9")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Print results to VBA's immediate window
Dim sum As Double
For Each K In d.Keys
Debug.Print K & ": " & d(K)
sum = sum + d(K)
Next
Debug.Print "Total: " & sum
End Sub
I'm trying to return all rows of data of an unknown amount [8 rows] from two columns. I get the subscript out of range error for >> SERnumber(rws, clm).
I'm simply trying to return:
in AAA
out AAA
in AAA
in VVV
in GGG
Here's my non-working code:
Sub Button1_Click()
Dim SERnumber() As String
Dim i As Integer
Dim strMessage As String
Dim rws As Integer
Dim clm As Integer
' assign variable > rws the # of rows containing data
rws = Cells(Rows.Count, 2).End(xlUp).Row
' Redimension the SERnumber array variable >>
' for n? rows and 2 columns
ReDim SERnumber(1 To rws, clm)
For i = 1 To rws
For clm = 1 To 2
SERnumber(rws, clm) = Cells(rws, clm).Value
Next clm
Next i
' Loop through the array and add the names to a string
strMessage = "Here are the results:" & vbCrLf
For i = 0 To rws
strMessage = strMessage & SERnumber(i) & vbCrLf
Next 'i
MsgBox strMessage
End Sub
You can assign Excel Range to VBA Array object as shown in the following VBA code example (Range includes entire columns A and B):
Sub Range2Array()
Dim arr As Variant
arr = Range("A:B").Value
'alternatively
'arr = Range("A:B")
'test
Debug.Print (arr(1, 1))
End Sub
Such direct assignment to 2d-array has tremendous performance advantage vs using the Range iteration. You can then perform all necessary operations on array elements instead of range cells (it also will be really fast in comparison to iterative range ops).
Another useful technique is to assign Excel's UsedRange to VBA Array:
arr = ActiveSheet.UsedRange
And, the most trivial example (pertinent to your case of 2 columns, 8 rows):
arr = Range("A1:B8").Value
Hope this will help. Best regards,
I'm trying to search a worksheet for a row where the values in the first 3 columns match a set of 3 criteria. I'm using this linear search:
Function findRow(pName as string,fNo as string,mType as string) As Long
Dim rowCtr As Long
rowCtr = 2
While Not rowMatchesCriteria(rowCtr, pName,fNo,mType)
rowCtr = rowCtr + 1
Wend
findRow=rowCtr
End Function
Function rowMatchesCriteria(row As Long, pName As String, fNo As String, mType As String) As Boolean
rowMatchesCriteria = dSheet.Cells(row,1)=pName _
And dSheet.Cells(row,2)=fNo _
And dSheet.Cells(row,3)=mType
End Function
We can assume that for any 3 criteria, there is only one match. However, this is very slow. dSheet has ~35,000 entries to search through, and I need to perform ~400,000 searches.
I looked at some of the solutions in this question, and while I'm sure that using AutoFilter or an advanced would be faster than a linear search, I don't understand how to get the index of the row that the filter returns. What I'm looking for would be:
Sub makeUpdate(c1 as string,c2 as string,c3 as string)
Dim result as long
result = findRow(c1,c2,c3)
dSheet.Cells(result,updateColumn) = someUpdateValue
End Sub
How do I actually return the result row that I'm looking for once I've applied AutoFilter?
For performance you're hard-pressed to beat a Dictionary-based lookup table:
Sub FindMatches()
Dim d As Object, rw As Range, k, t
Dim arr, arrOut, nR, n
t = Timer
'create the row map (40k rows)
Set d = GetRowLookup(Sheets("Sheet1").Range("A2:C40001"))
Debug.Print Timer - t, "map"
t = Timer
'run lookups on the row map
'(same values I used to create the map, but randomly-sorted)
For Each rw In Sheets("sheet2").Range("A2:C480000").Rows
k = GetKey(rw)
If d.exists(k) Then rw.Cells(3).Offset(0, 1).Value = d(k)
Next rw
Debug.Print Timer - t, "slow version"
t = Timer
'run lookups again - faster version
arr = Sheets("sheet2").Range("A2:C480000").Value
nR = UBound(arr, 1)
ReDim arrOut(1 To nR, 1 To 1)
For n = 1 To nR
k = arr(n, 1) & Chr(0) & arr(n, 2) & Chr(0) & arr(n, 3)
If d.exists(k) Then arrOut(n, 1) = d(k)
Next n
Sheets("sheet2").Range("D2").Resize(nR, 1).Value = arrOut
Debug.Print Timer - t, "fast version"
End Sub
'create a dictionary lookup based on three column values
Function GetRowLookup(rng As Range)
Dim d As Object, k, rw As Range
Set d = CreateObject("scripting.dictionary")
For Each rw In rng.Rows
k = GetKey(rw)
d.Add k, rw.Cells(1).Row 'not checking for duplicates!
Next rw
Set GetRowLookup = d
End Function
'create a key from a given row
Function GetKey(rw As Range)
GetKey = rw.Cells(1).Value & Chr(0) & rw.Cells(2).Value & _
Chr(0) & rw.Cells(3).Value
End Function
If you want to do an exact lookup on 3 columns, you can use VLOOKUP using a slight trick: you create a key based on your 3 columns. E.g. if you want to perform your query on columns B, C, D, create a key column in A based on your three columns (e.g. =B1&C1&D1). Then:
=VLOOKUP(lookupvalue1&lookupvalue2&lookupvalue3,A:D,{2,3,4},FALSE)
should do the magic.
One simple solution could be using excel function MATCH as array formula.
No for-each loops so I guess this could run very fast.
Formula will look e.g. like this MATCH("A"&"B"&"C",RANGE_1&RANGE_2&RANGE_3,0)
Option Explicit
Private Const FORMULA_TEMPLATE As String = _
"=MATCH(""CRITERIA_1""&""CRITERIA_2""&""CRITERIA_3"",RANGE_1&RANGE_2&RANGE_3,MATCH_TYPE)"
Private Const EXACT_MATCH = 0
Sub test()
Dim result
result = findRow("A", "B", "C")
Debug.Print "A,B,C was found on row : [" & result & "]"
End Sub
Function findRow(pName As String, fNo As String, mType As String) As Long
On Error GoTo Err_Handler
Dim originalReferenceStyle
originalReferenceStyle = Application.ReferenceStyle
Application.ReferenceStyle = xlR1C1
Dim data As Range
Set data = ActiveSheet.UsedRange
Dim formula As String
' Add criteria
formula = Replace(FORMULA_TEMPLATE, "CRITERIA_1", pName)
formula = Replace(formula, "CRITERIA_2", fNo)
formula = Replace(formula, "CRITERIA_3", mType)
' Add ranges where search
formula = Replace(formula, "RANGE_1", data.Columns(1).Address(ReferenceStyle:=xlR1C1))
formula = Replace(formula, "RANGE_2", data.Columns(2).Address(ReferenceStyle:=xlR1C1))
formula = Replace(formula, "RANGE_3", data.Columns(3).Address(ReferenceStyle:=xlR1C1))
' Add match type
formula = Replace(formula, "MATCH_TYPE", EXACT_MATCH)
' Get formula result
findRow = Application.Evaluate(formula)
Err_Handler:
' Set reference style back
Application.ReferenceStyle = originalReferenceStyle
End Function
Output: A,B,C was found on row : [4]
In order to improve the best answer (multi criteria search), you would want to check for duplicates to avoid error.
'create a dictionary lookup based on three column values
Function GetRowLookup(rng As Range)
Dim d As Object, k, rw As Range
Set d = CreateObject("scripting.dictionary")
For Each rw In rng.Rows
k = GetKey(rw)
if not d.exists(k) then
d.Add k, rw.Cells(1).Row 'checking for duplicates!
end if
Next rw
Set GetRowLookup = d
End Function