I'm very new at VBA I'm wanting to copy and transpose multiple columns and rows. Bonus if I can get alternating blank columns in between. I can get the first column to move but I'm stuck there. I'm assuming I can make a loop somehow? Here is what I'm trying to do for all data A1 to H12.
Thank you
Please, try the next code:
Sub ProcessRange()
Dim sh As Worksheet, arr, arrFin, i As Long, j As Long, r As Long, c As Long
Set sh = ActiveSheet
arr = sh.Range("B3:M10").value 'put the range to be processed in an array
ReDim arrFin(1 To UBound(arr) / 2, 1 To UBound(arr, 2) * 2) 'ReDim the array to keep the processing result
r = r + 1: c = c + 1 'initialize variables (r = rows, c = columns) for the final array
For j = 1 To UBound(arr, 2) 'iterate between the processed array columns
For i = 1 To UBound(arr) 'iterate between the processed array rows
If i Mod 2 = 1 Then
arrFin(r, c) = arr(i, j) 'extract the cases of odd rows
Else
arrFin(r, c + 1) = arr(i, j): r = r + 1 'extract the case of even rows and increment the row
End If
If i = UBound(arr) Then r = 1: c = c + 2 'reinitialize the row variable and increment the column one
Next i
Next j
'drop the processed array content at once:
sh.Range("B17").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub
I make an exception, supposing that you, being new, do not understand the community spirit and rules and answer a question which cannot prove any effort to solve the problem by your own and show us a piece of code, even a not working one.
Please, learn that and ask questions only in the community spirit.
You must learn that we here only help you correct your not working solution.
Related
I need to copy the Employee Name in Column I until a new Employee Comes up. For example, Copy Brown, Nat till row 8 i.e. Code: Shift 1, then start copying Brown, Rob. I used If with find function but i cant make it work.
Your question is mighty short on detail but the function below should help you get one step nearer to what you need. Please try it.
Private Function EmployeeData(ByVal FirstRow As Long) As Variant
' 233
Dim Arr As Variant
Dim Cl As Long ' last used column
Dim R As Long ' lop counter: rows
With Worksheets("Sheet1")
Arr = .Range(.Cells(1, "I"), .Cells(.Rows.Count, "I").End(xlUp)).Value
R = FirstRow
Do
If InStr(1, Arr(R + 1, 1), "Employee Name:", vbTextCompare) = 1 Then Exit Do
R = R + 1
Loop While R < UBound(Arr)
With .UsedRange
Cl = .Columns.Count + .Column - 1
End With
EmployeeData = .Range(.Cells(FirstRow, "A"), .Cells(R, Cl)).Value
End With
End Function
The function takes one argument. That is the number of the row where the employee's name is first found. Starting from that row, the function searches until the next name is found in column I and returns the data from the rows in between. It returns all data, from column A to the last used column.
Use the procedure below to test. Observe that EmployeeData(14) specifies row 14 as the first row of a block and that the loop that follows just prints column I:I although the array contains all the columns.
Sub GetData()
' 233
Dim Arr As Variant
Dim R As Long
Arr = EmployeeData(14)
For R = 1 To UBound(Arr)
Debug.Print Arr(R, 9)
Next R
End Sub
In real life, you will probably need to search for the first row before you can run this code. That search, if needed, is easy to integrate into the test procedure.
I am doing some code to put a range into an array so i can create plots by analyzing the data inside that array. I am trying to use a general code for the range since the input can be different depending on the type of analysis i want to perform. Tried to find a solution for this in other questions without success.
Dim DieBankArray As Variant
last_row = Sheets("Tabela CT geral").Range("A2").End(xlDown).Row 'Last row of the data set
For i = 0 To last_row - 2 '-2 to exclude the first line and another value because the array first position is 0, not 1
DieBankArray(i) = Range("A" & i + 2)
Next
The return is a type mismatch error that i can't understand...
Here's one approach:
Function RangeTo1DArray(rngStart As Range)
Dim rv(), arr, r As Long, n As Long
'read the source data to an array for better performance
With rngStart.Parent
arr = .Range(rngStart, .Cells(Rows.Count, rngStart.Column).End(xlUp)).Value
End With
n = UBound(arr, 1)
ReDim rv(0 To n - 1)
'Fill the output array. Note: purposefully not using transpose()
' to avoid its limitations
For r = 1 To n
rv(r - 1) = arr(r, 1)
Next r
RangeTo1DArray= rv
End Function
Ok, i used the Redim and it worked just fine.
What i couldn't understand is that there's a need to set the correct size of an array to read/write data. I thought a simple Dim as Variant should be enough to store the data at my will without need to set a correct size each time i want to use an array.
The code after ReDim:
Dim DieBankArray As Variant
last_row = Sheets("Tabela CT geral").Range("A2").End(xlDown).Row 'Last row of the data set
ReDim DieBankArray(A2 To last_row - 2)
For i = 0 To last_row - 2 '-2 to exclude the first line and another value because the array first position is 0, not 1
DieBankArray(i) = Range("A" & i + 2)
Next
I have this code to find the values that belong to the value in cell C3 (and further down):
aantalrijen = .Range("A2", .Range("A2").End(xlDown)).Cells.Count
For I = 2 To aantalrijen + 1
For J = 108 To 112
For Each cell In .Range(.Cells(2, J), .Cells(aantalrijen, J)).Cells
cell.Value = Application.VLookup(.Cells(I, 3), Sheets("omzet").Range("C:DH"), J - 2, 0)
Next cell
Next J
Next I
I am aware this cannot be the most efficient way to get the desired result. How should I adjust the code to make it the most efficient?
Update:
For now I am satisfied with this result:
aantalrijen = .Range("A2", .Range("A2").End(xlDown)).Cells.Count
For J = 108 To 112
For I = 2 To aantalrijen
.Cells(I, J).Value = Application.VLookup(.Cells(I, 3), Sheets("omzet").Range("C:DH"), J - 2, 0)
Next I
Next J
End With
it is fast enough for me now and it returns the desired results.
Here:
Option Explicit
Sub Test()
Dim arrSource, arrData, i As Long, j As Long, ColI As Long, ColF As Long
Dim DictMatches As New Scripting.Dictionary
Dim DictHeaders As New Scripting.Dictionary
With ThisWorkbook
arrSource = .Sheets("omzet").UsedRange.Value
arrData = .Sheets("SheetName").UsedRange.Value 'change this for the worksheet you are working on
End With
For i = 1 To UBound(arrSource, 2) 'this will store the headers position
DictHeaders.Add arrSource(1, i) 'this will throw an error if you have any duplicate headers
Next i
For i = 2 To UBound(arrSource) 'this will store the row position for each match
DictMatches.Add arrSource(i, 3), i 'this will throw an error if you have any duplicates
Next i
'Here you can change where you want to evaluate your data
ColI = 108
ColF = 112
For i = 2 To UBound(arrData) 'loop through rows
For j = ColI To ColF 'loop through columns
arrData(i, j) = arrSource(DictMatches(arrData(i, 3), DictHeaders(1, j)))
Next j
Next i
'Paste the arrData back to the sheet
ThisWorkbook.Sheets("SheetName").UsedRange.Value = arrData
End Sub
This is the fastest way, why?
You store both sheets into the arrays and from then on you work only with the arrays(which means working on memory, so working faster)
Using excel functions always slow downs the process, instead we are storing all the index values on rows and headers for the omzet sheet, so when you point to a value from Column C on your working sheet, it gives you the result without calculating anything.
Here: arrSource(DictMatches(arrData(i, 3), DictHeaders(1, j))) we are giving a row position and column position.
DictMatches(arrData(i, 3) will give you back the row where that match was found inside the dicitonary. DictHeaders(1, j) will give you back the column where that header was found inside the dictionary.
Note: for dictionaries to work you need the Microsoft Scripting Runtime library checked on your references. Also Dictionaries are Case Sensitiveso Hello <> hello.
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 4 years ago.
Improve this question
I will admit that Excel is far from my strength, so any help would be appreciated.
We have a large pull of data in an excel spreadsheet (~15,000 lines) that needs to be reported against.
For each item in Column A, there are one or more values in Column B.
The table below depicts what I mean, albeit at a VERY small scale:
Is there a way to have Excel run through such a table, and for each unique value in Column A, compile a comma separated list for every corresponding value in Column B.
i.e.
Thanks for your help in advance.
This is for andy:
use the array formula:
=TEXTJOIN(",",TRUE,IF(A1:A7="andy",B1:B7,""))
Array formulas must be entered with Ctrl + Shift + Enter rather than just the Enter key. If this is done correctly, the formula will appear with curly braces around it in the Formula Bar.
Repeat the formula for each unique name.
EDIT#1:
To automate this:
copy column A to column C
use Excel's RemoveDuplicates feature to create a list of unique names
apply the array formula to each member of that unique list.
EDIT#2:
To automate with VBA, run this short macro:
Sub PleaseAutomate()
Dim N As Long
Dim M As Long
M = Cells(Rows.Count, "A").End(xlUp).Row
Columns(1).Copy Columns(3)
Columns(3).RemoveDuplicates Columns:=1, Header:=xlNo
N = Cells(Rows.Count, "C").End(xlUp).Row
Range("D1").FormulaArray = "=TEXTJOIN("","",TRUE,IF($A$1:$A$" & M & "=C1,$B$1:$B$" & M & ",""""))"
Range("D1").Copy Range("D2:D" & N)
End Sub
This will handle your entire data set. Have a look at the comments and update your ranges in the two places it specifies. To be honest though where's your data pulled from? I'm assuming a database. You should probably handle this in your data feed instead
Public Sub ValuestoStringSeparated()
Dim Data As Variant, Results As Variant, tmp As Variant
Dim Dict As Object
Dim i As Long
Dim Key
Set Dict = CreateObject("Scripting.Dictionary")
' Update this to your sheet Ref
With ActiveSheet
Data = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2)).Value2
End With
' Add your raw data to Dictionary
For i = LBound(Data, 1) To UBound(Data, 1)
If Not Dict.Exists(Data(i, 1)) Then
ReDim tmp(0)
tmp(0) = Data(i, 2)
Dict.Add Key:=Data(i, 1), Item:=tmp
Else
tmp = Dict(Data(i, 1))
ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
tmp(UBound(tmp)) = Data(i, 2)
Dict(Data(i, 1)) = tmp
End If
Erase tmp
Next i
' Print your Data to sheet
ReDim Results(1 To Dict.Count, 1 To 2)
i = 0
For Each Key In Dict.keys
i = i + 1
Results(i, 1) = Key
Results(i, 2) = Join(Dict(Key), ", ")
Next Key
' Update with your desired output destination
With ActiveSheet.Range("D2")
.Resize(UBound(Results, 1), UBound(Results, 2)).Value2 = Results
End With
End Sub
Approach via dictionary and datafield array
Similar to the #Tom 's good solution above :+), but joining insurance types already in dictionary and avoiding a constant ReDim Preserve of an additional tmp array. Note: I decided to use counters instead of the correct LBound and UBound counts for better readability, thus allowing an easy range definition, too.
Code
Option Explicit
Sub JoinTypes()
Const DELI As String = ","
Dim dict As Object, d
Dim i As Long, n As Long
Dim sKey As String
Dim v As Variant, Results() As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Test") ' << change to your sheet name
Set dict = CreateObject("Scripting.Dictionary") ' dictionary object
' [1] get last row in column A
n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
' [2] read data into 1-based 2-dim datafield array
v = ws.Range("A1:B" & n)
' [3] get Customers and collect joined values into dictionary (omit title row)
For i = 2 To n
sKey = v(i, 1)
If dict.Exists(sKey) Then ' join insurance types (delimiter ",")
dict(sKey) = dict(sKey) & DELI & v(i, 2)
Else ' start new customer
dict.Add key:=sKey, Item:=v(i, 2)
End If
Next i
Erase v
' [4] write joined values into new array
n = dict.Count ' redefine counter
ReDim Results(1 To n, 1 To 2) ' redimension new array ONLY ONCE :-)
i = 0
For Each d In dict.keys ' loop through customers in dictionary keys
i = i + 1: Results(i, 1) = d: Results(i, 2) = dict(d)
Next d
' [5] write array back to sheet (e.g. column D:E omitting title row)
ws.Range("D2:E" & n + 1) = Results
' [6] clear memory
Set ws = Nothing: Set dict = Nothing
End Sub
I've been struggling with this code here (probably very simple mistake), would anyone mind pointing out where my issues are? My overall goal is to allow this subroutine to accept a range of variable size, however I can't seem to get it to work for a fixed size.
If I manually allocate the array, things work as expected but when I allocate with a range that's where things go wrong. The output comes back untouched, which leads me to believe that I'm not doing something correctly with the allocation. Also I'm getting errors when I try to pass ws.UsedRange as oppose to a fixed range.
Private Sub InsertionSort(ByRef a(), ByVal lo0 As Long, ByVal hi0 As Long)
Dim i As Long, j As Long, v As Long
For i = lo0 + 1 To hi0
v = a(i)
j = i
Do While j > lo0
If Not a(j - 1) > v Then Exit Do
a(j) = a(j - 1)
j = j - 1
Loop
a(j) = v
Next i
End Sub
Sub runSort()
Dim ws As Worksheet
Set ws = ActiveWorkbook.ActiveSheet
Dim myArr() As Variant
Dim rangeUse As Range
With ws.Range("D17:K17")
ReDim myArr(1 To 1, 1 To ws.Range("D17:K17").Columns.Count)
myArr = ws.Range("D17:K17").Value
End With
Call InsertionSort(myArr, LBound(myArr), UBound(myArr))
Range("D19:K19") = myArr
End Sub
Any help would be appreciated! TIA
So considerating you only want to sort your 2-dimensional array row by row, this might be a useful starting point. You can always change With ws.Range("A2:A3") to With Selection. If you do so, you have the Range you selected with your cursor.
With ws.Range("A2:A3")
myArr = .Value
For i = 1 To .Rows.Count
ReDim tmpArr(1 To .Columns.Count)
For j = 1 To .Columns.Count
tmpArr(j) = myArr(i, j)
Next j
Call InsertionSort(tmpArr, 1, .Columns.Count)
For j = 1 To .Columns.Count
myArr(i, j) = tmpArr(j)
Next j
Next i
.Offset(RowOffset:=10) = myArr
End With
Detailed Description
You don't have to redim myArray because if you set it to a range, it automatically scales.
tmpArr is each row of your range. If you select your range with the cursor some rows might be shorter or longer than others, thats why we redim that one. Edit This doesn't work just yet, because .Columns.Count refers to the whole range, not just the row. If you have different column counts then you'd have to change that.
For j = 1 To .Columns.Count
tmpArr(j) = myArr(i, j)
Next j
Unfortunately we cannot use tmpArr = myArr(i) because only one dimension of a multidimensional array cannot be accessed like this in VBA.
Call InsertionSort(tmpArr, 1, .Columns.Count) calles your Insertion Sort algorithm and sorts one row at a time.
After tmpArray got sorted, we have to set myArray(i) to the new values with the same loop we already used:
For j = 1 To .Columns.Count
myArr(i, j) = tmpArr(j)
Next j
Now we sorted all the rows in our Range, now we can put it back on the sheet, 10 rows beneath the first row of the specified range with .Offset(RowOffset:=10) = myArr
I hope that this helps you! While testing I saw that you might have a little bug in your InsertionSort algorithm. If the first value is the smalles, it just blindly gets copied into all the other fields of the array :)