Code works great but data moved from cols EFG to bottom of BCD loses leading zeros, I need the data to be copied as is. I have variable length data in col E ie 03456,001234567,0123 when the data copies to the bottom of cols BCD I need it to still have the zeros, if someone can help that would be great. Thanks
Sub moveColumnsData()
Dim sourceLastRow As Long
Dim destLastRow As Long
Dim lastColumn As Long
Dim i As Long
Dim sourceRng As Range
Dim destRng As Range
Dim a As Range
With ActiveSheet
lastColumn = .UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
'loop through every set of 3 columns
For i = 5 To lastColumn Step 3
sourceLastRow = .Range(.Columns(i), .Columns(i + 2)).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'incase columns BCD are blank then set last row=1
Set a = .Columns("B:D").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious)
If Not a Is Nothing Then
destLastRow = a.Row + 1
Else
destLastRow = 1
End If
'no need to use copy/paste, just let the range equals to each other
Set sourceRng = .Range(.Cells(1, i), .Cells(sourceLastRow, i + 2))
.Cells(destLastRow, "B").Resize(sourceRng.Rows.Count, sourceRng.Columns.Count) = sourceRng.value
Next
'uncomment below to clear all columns besides BCD
'.Range(.Columns("E"), .Columns(lastColumn)).Clear
End With
End Sub
data copies from col EFG to the bottom of BCD loses leading zeros, not sure what to add and where.
Related
I have a very basic question, but would love to know how to do this. I want to write a function in VBA where I can highlight a column as an input, and then spit out the result somewhere else.
Thanks in advance :)
e.g. column A
--------
10
8
5
6
1
3
2
becomes:
column A
--------
10
8
6
2
I just did it from column a to b, but you probably want range as the current selection and a different output column.
Option Explicit
Sub filterlist()
Dim rng As Range
Set rng = Range("a1:a5")
Dim celluse As Range
Dim arr As Variant
For Each celluse In rng
If celluse.Value Mod 2 = 0 Then
If IsEmpty(arr) Then
arr = Array(celluse.Value)
Else
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = celluse.Value
End If
End If
Next celluse
Dim i As Long
For i = 0 To UBound(arr)
Range("b" & i + 1) = arr(i)
Next i
End Sub
This code should do the trick.
You can enter as an array-formula directly to a sheet: {=RemoveOdds(A1:A7)} or as part of another procedure:
Sub Test()
RemoveOdds Selection
End Sub
Public Function RemoveOdds(Target As Range) As Variant
Dim vFinal() As Variant
Dim rCell As Range
Dim x As Long
ReDim vFinal(1 To Target.Cells.Count)
x = 1
For Each rCell In Target
If rCell Mod 2 = 0 Then
vFinal(x) = rCell.Value
x = x + 1
End If
Next rCell
'So missing values do not show up as 0 at bottom of array.
' Do While x <= Target.Cells.Count
' vFinal(x) = ""
' x = x + 1
' Loop
ReDim Preserve vFinal(1 To x - 1)
'RemoveOdds = vFinal 'Basic array - will place values horizontally on sheet.
RemoveOdds = Application.Transpose(vFinal) 'Will place values vertically on sheet.
End Function
I have a code for an array that saves all the data from my spreadsheet in columns D to I, however it also saves all of the blank cells from the sheet too which I don't want. All of the columns have the same number of rows, but ideally I want the array for every row from the second until it finds the last repetition of the max that it works out from column D. My code is:
Sub PopulatingArrayVariable()
Dim myArray() As Variant
Dim DataRange As Range
Dim cell As Range
Dim x As Long
Dim TotalTargets As Double
TotalTargets = WorksheetFunction.Max(Columns("D"))
Set DataRange = Sheets("Result").Range("D:I")
For Each cell In DataRange.Cells
ReDim Preserve myArray(x)
myArray(x) = cell.Value
x = x + 1
Next cell
End Sub
Here's an alternative approach which should skip ReDim Preserve altogether.
See if it helps your situation.
Sub BuildArray()
Dim lngLastRow As Long
Dim rng As Range
Dim arList As Object
Dim varOut As Variant
lngLastRow = Sheets("Result").Range("D:I").Find("*", Sheets("Result").Range("D1"), , , xlByRows, xlPrevious).Row
Set arList = CreateObject("System.Collections.ArrayList")
For Each rng In Sheets("Result").Range("D1:I" & lngLastRow)
If Len(Trim(rng.Value)) > 0 Then
arList.Add rng.Value
End If
Next
varOut = arList.ToArray
End Sub
Add a condition for the length of the cell before adding to the array:
For Each cell In DataRange.Cells
If Len(Trim(Cells)) > 0 Then
ReDim Preserve myArray(x)
myArray(x) = cell.Value
x = x + 1
End If
Next cell
The Trim() would remove the spaces from left and right, thus if there is a cell with just one space like this it would still give 0 and would not be taken into account.
Trim MSDN
I'm working on a project for work and I've hit a wall. I'm trying to automate some formatting to speed up a process. On Sheet1, there is a table in the range G2 to W21. The data contained in this table is entered by the user via a userform. After the data is entered, I use this data to drive out Sheet2 is formatted. So far, I've figured out how to handle column G & H of this table the way that I want. I cant figure out how to handle columns I:M and O:W.
Here is the code I've come up with so far:
Dim LineItems As Range, Cell As Range
Dim linearr() As Variant
Dim datasetarr() As Variant
Dim i As Integer
Dim j As Integer
Dim accountnum As Range
Dim accountnumrng As Range
Set LineItems = Sheet1.Range("H2:H21")
Set DataSets = Sheet1.Range("G2:G21")
For Each Cell In LineItems
If Len(Cell.Value) > 0 Then
i = i + 1
ReDim Preserve linearr(1 To i)
linearr(i) = Cell.Value
End If
Next Cell
For Each Cell In DataSets
If Len(Cell.Value) > 0 Then
j = j + 1
ReDim Preserve datasetarr(1 To j)
datasetarr(j) = Cell.Value
End If
Next Cell
Set accountnumrng = Sheet2.Range("B6:B1000").SpecialCells(xlCellTypeConstants, 23)
For Each accountnum In accountnumrng.Cells
accountnum.Offset(1, 1).Cells(1, 1).Resize(UBound(linearr), 1).Value = Application.Transpose(linearr)
accountnum.Offset(1, 0).Cells(1, 1).Resize(UBound(datasetarr), 1).Value = Application.Transpose(datasetarr)
Next accountnum
here is a picture of the table on Sheet1. Outlined in red are the columns I'm trying to work with
I basically just want to expand on what I've figured out so far. Any help would be greatly appreciated.
Below is a Picture of what Sheet2 looks like right now
Below is what I'd like Sheet2 to look like
There is no reason to use an array. Ranges are arrays by their nature.
This should do what you want:
Dim accountnum As Range
Dim accountnumrng As Range
Dim lastrow As Long
Dim sze As Long
lastrow = Sheet1.Range("G2").End(xlDown).Row
sze = lastrow - 2 + 1
Set accountnumrng = Sheet2.Range("B6:B1000").SpecialCells(xlCellTypeConstants, 23)
For Each accountnum In accountnumrng.Cells
accountnum.Offset(1, 8).Resize(sze, 9).Value = Sheet1.Range("O2:W" & lastrow).value
accountnum.Offset(1, 0).Resize(sze, 7).Value = Sheet1.Range("G2:M" & lastrow).value
Next accountnum
Warning: Complex situation requires wall of text
What I have as data
In sheet A, I have alphanumerical numbers In column A and sometimes, suppliers in columns B, C, D.
colA colB colC colD
H-19328 SupA SupB SupA
H-12801 SupC SupD
H-32829
H-23123 SupB SupC
....... .... .... ....
In sheet B, I have alphanumerical numbers in column A, and 1 supplier in column B. I also have a bunch of other information in the next columns.
colA colB colC colD
H-19328 SupA stuffs stuffs
H-52601 SupA stuffs stuffs
H-3279 SupA stuffs stuffs
H-4987123 SupB stuffs stuffs
....... .... ...... ......
In sheet A, the alphanumerical number is unique in the list. The numbers in sheet A may or may not have a matching number in sheet B and vice versa. Even when the number matches, the suppliers may or may not match.
What I want to do
For each number in sheet A, I want to check if sheet B holds that number with the associated supplier.
For example, for the first number H-19328, I will check if sheet B has:
colA colB colC colD
H-19328 SupA stuffs stuffs < This could match twice as it was twice in A
H-19328 SupB stuffs stuffs
I don't know if the number/supplier combo will match, and if it does, I don't know how many times it will match. I want to retrieve the values from sheet B in the other columns, C and D.
What I have as code
I put the values in column A of sheet A in a dictionnary. The keys are the numbers, and the Supplier information is in an array tied to each key. The dictionnary works well. The issue is not about the dictionnary, if you are not good with them you can still help me.
Right now I have a loop that matches every key + supplier to the sheet b list and returns how many times it matched. To dispel confusion, Dict_Sup is the dictionnary. Dict_sup.items(1) is an array containing suppliers. Dict_sup.items(1)(0) is the first entry of that array. Dict_sup.items(1)(supcount) is the last entry of that array.
For i = 0 To Dict_Sup.Count - 1
For j = 0 To supcount 'supcount is the size of the array containing the suppliers
nb_of_matches = TimesExtracted(Dict_Sup.Keys(i), Dict_Sup.Items(i)(j))
Next j
Next
The function TimesExtracted looks into sheet B (which is an extract, sheet name is SupDocs) and matches what I mentioned to look at the number of matches. Here it is:
Function TimesExtracted(Key As String, Sup As String) As Integer()
Dim lastline As Integer
Dim AllSupDocs As Range
Dim SupDoc As Range
lastline = SupDocs.Range("A" & Rows.Count).End(xlUp).Row
Set AllSupDocs = SupDocs.Range("E1:E" & lastline)
For Each SupDoc In AllSupDocs
If SupDoc.Value = Key And SupDoc(, 61).Value = Sup Then
Timesextracted = TimesExtracted + 1
End If
Next
End Function
I would like to transform this function so that it would send the 'stuffs' on which it found matches, instead of sending the amount of matches. There are 3 'stuffs' values I want. I tried making it an Array function, but I was not successful in redimensioning the array to send back an appropriate amount of results;
Function TimesExtracted(Key As String, Sup As String) As String()
Dim lastline As Integer
Dim AllSupDocs As Range
Dim SupDoc As Range
Dim tmpArray(0) As String
Dim j As Integer
lastline = SupDocs.Range("A" & Rows.Count).End(xlUp).Row
Set AllSupDocs = SupDocs.Range("E1:E" & lastline)
For Each SupDoc In AllSupDocs
If SupDoc.Value = Key And SupDoc(, 61).Value = Sup Then
ReDim Preserve tmpArray(UBound(tmpArray) To UBound(tmpArray) + 2) 'adds 2 places in the array
tmpArray(j) = SupDoc(, 3).Value
tmpArray(j + 1) = SupDoc(, 4)Value
j = j + 2
End If
Next
Timesextracted = tmpArray 'Doing this so I can redim
End Function
Is there a better way to return the values I want? Am i making this way too complex? If both answers are no, then what do i need to modify in this last block for it to send an array with the following information
If only SupA matched in column A100:
(C100.Value, D100.Value)
If supA matched in A100 and matched again in A110:
(C100.Value, D100.Value, C110.Value, D110.Value)
It is pretty simple actually. I have commented the code but if you still have a problem understanding it then let me know :)
Const sep As String = "|"
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet, WsRef As Worksheet
Dim col As New Collection, itm
Dim i As Long, j As Long, lRow As Long
Dim aCell As Range
Set wsI = Sheet1 '<~~ Sheet A as per your data
Set WsRef = Sheet2 '<~~ Sheet B as per your data
Set wsO = Sheet3 '~~< New Sheet for Output
With wsI
'~~> Find last row of col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> What the code does is joins Col A value in Sheet A
'~~> First with Col B and then with Col C and then with
'~~> Col D and stores them in a unique collection
'~~> Looping from row 1 to last row
For i = 1 To lRow
'~~> Looping from Col B to Col D
For j = 2 To 4
sString = wsI.Cells(i, 1) & sep & wsI.Cells(i, j)
On Error Resume Next
col.Add sString, CStr(sString)
On Error GoTo 0
Next j
Next i
End With
j = 1 '<~~ First Row in Output Sheet
'~~> Looping through the unique collection
For Each itm In col
'~~> Extraction the alphanumerical value and finding it in Sheet B
Set aCell = WsRef.Columns(1).Find(What:=Split(itm, sep)(0), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> If Found
If Not aCell Is Nothing Then
wsO.Cells(j, 1).Value = Split(itm, sep)(0)
wsO.Cells(j, 2).Value = Split(itm, sep)(1)
wsO.Cells(j, 3).Value = aCell.Offset(, 2)
wsO.Cells(j, 4).Value = aCell.Offset(, 3)
j = j + 1
End If
Next
End Sub
NOTE: If you have huge rows of data then I would recommend copy the data from SheetA and SheetB into separate arrays and then do all the above in memory so that the execution is faster.
Followup From comments
Is this what you are trying?
Sub Sample()
Dim tmpAr As Variant
tmpAr = TimesExtracted("H-19328", "SupA")
If IsArray(tmpAr) Then
For i = 1 To UBound(tmpAr)
Debug.Print tmpAr(i, 1) & "," & tmpAr(i, 2)
Next i
Else
Debug.Print tmpAr
End If
End Sub
Function TimesExtracted(Key As String, Sup As String) As Variant
Dim MyAr As Variant
Dim wsRef As Worksheet, rngWsRef As Range
Dim bCell As Range, oRange As Range
Dim ListRange As Range
TimesExtracted = "Not Found"
Set wsRef = Sheet2 '<~~ Sheet B as per your data
Set ListRange = wsRef.Columns(1)
n = Application.WorksheetFunction.CountIf(ListRange, Key)
If n <> 0 Then
ReDim MyAr(n, 2)
n = 1
Set oRange = ListRange.Find(what:=Key, LookIn:=xlValues, _
lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not oRange Is Nothing Then
Set bCell = oRange
MyAr(n, 1) = oRange.Offset(, 2).Value
MyAr(n, 2) = oRange.Offset(, 3).Value
n = n + 1
Do
Set oRange = ListRange.Find(what:=Key, After:=oRange, LookIn:=xlValues, _
lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not oRange Is Nothing Then
If oRange.Address = bCell.Address Then Exit Do
MyAr(n, 1) = oRange.Offset(, 2).Value
MyAr(n, 2) = oRange.Offset(, 3).Value
n = n + 1
Else
Exit Do
End If
Loop
TimesExtracted = MyAr
End If
End If
End Function
I think you should use already build V-lookup formula.
Declare name range for sheet b columns A-D lets say "NameR"
Than here is your lookup formula based to pull the values in from column D SheetB
=vlookup(A2,NameR,4,False)
your first column in the range should always be lookup values, 4th column column D return value. Also sort the the first column in the range.
I have the following (on the surface of it, simple) task:
Copy the values from a number of columns on a spreadsheet into a 2D array using VBA.
To make life more interesting, the columns are not adjacent, but they are all of the same length. Obviously one could do this by looping over every element in turn, but that seems very inelegant. I am hoping there is a more compact solution - but I struggle to find it.
Here are some attempts of what I would consider "a simple approach" - for simplicity, I am putting the range as A1:A5, D1:D5 - a total of 10 cells in two ranges.
Private Sub testIt()
Dim r1, r2, ra, rd, rad
Dim valString, valUnion, valBlock
Set r1 = Range("A1:A5")
Set r2 = Range("D1:D5")
valString = Range("A1:A5,D1:D5").Value
valUnion = Union(r1, r2).Value
valBlock = Range("A1:D5").Value
End Sub
When I look at each of these variables, the first two have dimension (1 To 5, 1 To 1) while the last one has (1 To 5, 1 To 4). I was expecting to get (1 To 5, 1 To 2) for the first two, but that was not the case.
I would be happy if I could loop over the data one column at the time, and assign all the values in one column to one column in the array - but I could not figure out how to do that either. Something like
cNames = Array("A", "D")
ci = 1
For Each c in columnNames
vals( , ci) = Range(c & "1:" & c & "5").Value
ci = ci + 1
Next c
But that's not the right syntax. The result I want to get would be achieved with
cNames = Array("A", "D")
ci = 1
For Each c in columnNames
For ri = 1 To 5
vals(ri , ci) = Range(c & "1").offset(ri-1,0).Value
Next ri
ci = ci + 1
Next c
But that's pretty ugly. So here is my question:
Is it possible to get the values of a "composite range" (multiple non-contiguous blocks) into an array - either all at once, or a columns at a time? If so, how do I do it?
For extra bonus points - can anyone explain why the arrays returned in testIt() are dimensioned Base 1, whereas my VBA is set to Option Base 0? In other words - why are they not (0 To 4, 0 To 0)? Is this just one more inconsistency on the part of Microsoft?
Provided each area in rng has the same number of rows then this should work.
Function ToArray(rng) As Variant()
Dim arr() As Variant, r As Long, nr As Long
Dim ar As Range, c As Range, cnum As Long, rnum As Long
Dim col As Range
nr = rng.Areas(1).Rows.Count
ReDim arr(1 To nr, 1 To rng.Cells.Count / nr)
cnum = 0
For Each ar In rng.Areas
For Each col In ar.Columns
cnum = cnum + 1
rnum = 1
For Each c In col.Cells
arr(rnum, cnum) = c.Value
rnum = rnum + 1 'EDIT: added missing line...
Next c
Next col
Next ar
ToArray = arr
End Function
Usage:
Dim arr
arr = ToArray(Activesheet.Range("A1:A5,D1:D5"))
Debug.Print UBound(arr,1), UBound(arr,2)
As for why array from rng.Value are 1-based instead of zero-based, I'd guess it's because that maps more readily to actual row/column numbers on the worksheet than if it were zero-based. The Option Base x setting is ignored
It is possible to accomplish what you want if you're willing to add a hidden worksheet. I used Excel 2010 and created two worksheets (Sheet1 / Sheet2) to test my findings. Below is the code:
Private Sub TestIt()
' Src = source
' Dst = destination
' WS = worksheet
Dim Data As Variant
Dim SrcWS As Excel.Worksheet
Dim DstWS As Excel.Worksheet
' Get a reference to the worksheet containing the
' source data
Set SrcWS = ThisWorkbook.Worksheets("Sheet1")
' Get a reference to a hidden worksheet.
Set DstWS = ThisWorkbook.Worksheets("Sheet2")
' Delete any data found on the hidden worksheet
DstWS.UsedRange.Columns.EntireColumn.Delete
' Copy the non-contiguous range into the hidden
' worksheet.
SrcWS.Range("A1:A5,D1:D5").Copy DstWS.Range("A1")
' Now all of the data can be stored in a variable
' as a 2D array because it will be contiguous on
' the hidden worksheet.
Data = DstWS.UsedRange.Value
End Sub
Tim,
Thanks for your sample code. I had some problems with it and had to rewrite some portions of it. It wasn't counting through the rows and columns correctly. I have test this and it is working 100%
Function ToArray(rng As Range) As Variant()
Dim arr() As Variant, r As Long, nr As Long
Dim ar As Range, c As Range, cnum As Long, rnum As Long
Dim col As Range
Dim lastrow As Integer
Dim saverow() As Integer
Dim lastcolumn As Integer
Dim templastcolumn As Integer
For i = 1 To rng.Areas.Count
templastcolumn = (rng.Areas(i).Column + rng.Areas(i).CountLarge) - 1
If lastrow <> rng.Areas(i).Row Then
nr = nr + rng.Areas(i).Rows.Count
lastrow = rng.Areas(i).Row
End If
If lastcolumn < templastcolumn Then lastcolumn = templastcolumn
Next i
ReDim arr(1 To nr, 1 To lastcolumn)
ReDim saverow(1 To lastrow)
cnum = 0
rnum = 0
lastrow = 0
For Each ar In rng.Areas
If lastrow <> ar.Row Then
lastrow = ar.Row
cnum = 0
End If
For Each col In ar.Columns
cnum = cnum + 1
For Each c In col.Cells
If saverow(c.Row) = 0 Then
rnum = rnum + 1
saverow(c.Row) = rnum
End If
arr(saverow(c.Row), cnum) = c.value
Next c
Next col
Next ar
ToArray = arr
End Function
Sub TestCopyArray()
Dim arr As Variant
arr = ToArray(ThisWorkbook.Sheets("MSS").Range("B1:D2,G1:J2,B4:D4,B6:D6"))
ThisWorkbook.Sheets("Sheet1").Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub