Based on an example I found on this site I made the following procedure. It prints only the first element of the array into the entire range instead of printing each element into each cell of the range. Do you have any idea what I'm doing wrong?
Thanks,
Crash
i = 2
Do Until Cells(i, 1) = "" 'loops through IDs in 1st column of spreadsheet
If Cells(i, 1) > "" Then 'if it finds an ID
GoSub CommentsColor 'sub that calculates a color -> thisColor
End If
ReDim Preserve colors(i - 2) 'start array at zero
colors(i - 2) = thisColor 'populate array
thisColor = "" 'clear variable
i = i + 1 'go to next ID in 1st column of spreadsheet
Loop
'set range
Set colorData = ActiveWorkbook.Worksheets("Movement_Data").Range(Cells(2, thisCol), Cells(i - 1, thisCol))
colorData.Value = colors 'print array to worksheet
Your range and cells references do not specifically belong to that worksheet; they belong to activesheet.
with ActiveWorkbook.Worksheets("Movement_Data")
Set colorData = .Range(.Cells(2, thisCol), .Cells(i - 1, thisCol))
end with
Transpose the array to match your destination.
colorData = application.transpose(colors) 'print array to worksheet
Better to simply resize the destination according to the array.
ActiveWorkbook.Worksheets("Movement_Data").Cells(2, thisCol).resize(ubound(colors)+1, 1) = application.transpose(colors)
Related
I am trying to write a process that compares strings and deletes the duplicate string within a given column using a selection as the top and bottom constraints.
Most of the process of checking and deleting works however I am having trouble with moving the cell contents up a cell after the duplicate string was deleted.
Image showing how the script should work
Red outline is the loop that selects the String to compare against.
Green outline is the loop that finds, deletes and moves the cells up one.
Blue outline is the Selection.
Stage 1 is to find and compare two strings that are the same.
Stage 2 is to delete the string that is the same as the first string.
Stage 3 is to move everything under the deleted cell with the deleted string up one row so that there is no empty cell.
I'm having problems with stage 3. I don't know how to move all data in those cells up one row without using a loop and I can't use the selection.
Here is the code so far:
Private Sub Tabeller()
Dim vRngMv As Variant
Dim iRowChsr1, iRowChsr2, iRowTtl, iI As Integer
Dim vRowIn, vRowComp As String
Dim oRngSlct, oRngMv As Range: Dim ws As Worksheet: Dim oBS As Object
'Newer Version will get rid of Selection as range determination
'Why does oRngSlct become a Variant/Object/Range here and oRngMv stays a Range object?
'I dont use it, kept it in to ask the question.
Set oRngMv = Selection: Set oRngSlct = Selection
iRowTtl = oRngSlct.Rows.Count
'First Loop For holding target cell data for comparison
For iRowChsr1 = 1 To iRowTtl
'Chooses target cell and string
vRowIn = oRngSlct(iRowChsr1, 1)
'Second loop for Seeking a matching String
For iRowChsr2 = 1 To iRowTtl
'Check to not pick itself
If iRowChsr1 = iRowChsr2 Then
'Offsets Counter by 1 if it enocunters itself
iRowChsr2 = iRowChsr2 + 1
Else
'Sets comparison string
vRowComp = oRngSlct(iRowChsr2, 1)
'String comparison
iI = StrComp(vRowIn, vRowComp, 1)
'If strings are equal
If iI = 0 Then
'Deletes; I know this is redundant but its here for clarity
oRngSlct(iRowChsr2, 1) = ""
'Offsets by iRowChsr by 1
iRowChsr2 = iRowChsr2 + 1
'Create Variant with proper range, it just has to be translated into something that excel can move.
vRngMv = Range((oRngSlct(iRowChsr2, 1)), (oRngSlct(iRowTtl, 1)))
Set oRngMv = Range 'I know this doesnt work
'Offsets back to original Position of Deleted cell
iRowChsr2 = iRowChsr2 - 1
'*******************************
'*Cuts and pastes or moves here*
'*******************************
End If
End If
'Next Comparison String
Next iRowChsr2
'Next target String
Next iRowChsr1
End Sub
Unique (Remove Duplicates)
You could rather use one of the following.
The first solution will leave error values and blanks as part of the resulting data, while the second one will remove them.
The Code
Option Explicit
Sub removeDupesColumnSelection()
' Validate Selection.
If TypeName(Selection) <> "Range" Then Exit Sub
' Remove duplicates.
Selection.Columns(1).RemoveDuplicates Array(1), xlNo
End Sub
Sub uniquifyColumnSelection()
' Validate Selection.
If TypeName(Selection) <> "Range" Then Exit Sub
' Write values from first column of Selection to Data Array.
Dim rg As Range: Set rg = Selection.Columns(1)
Dim rCount As Long: rCount = rg.Rows.Count
Dim Data As Variant
If rCount > 1 Then
Data = rg.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
End If
' In Unique Dictionary...
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
' Write unique values from Data Array to Unique Dictionary.
Dim Key As Variant
Dim i As Long
For i = 1 To rCount
Key = Data(i, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
.Item(Key) = Empty
End If
End If
Next i
ReDim Data(1 To rCount, 1 To 1)
If .Count > 1 Then
' Write values from Unique Dictionary to Data Array.
i = 0
For Each Key In .Keys
i = i + 1
Data(i, 1) = Key
Next Key
End If
End With
' Write values from Data Array to Destination Range.
rg.Value = Data
End Sub
I have two columns of data in a spreadsheet.
Column A has either cells containing "X" or empty cells and Column B contains formulas.
I want to use VBA to pull Column A into an array, and paste the array into Column B, making sure the "X"s copy over but the empty array elements do not.
The method I have looks at each array element and if it is an "X" then paste that 1 element, it works but its slow for large data pools. Is there a faster method?
See code below:
Option Explicit
Sub Test()
Dim array1 As Variant, i As Integer
array1 = Sheets("Sheet1").Range("A2:A8").Value
For i = 1 To UBound(array1)
If array1(i, 1) = "X" Then
Sheets("Sheet1").Cells(i + 1, 2) = array1(i, 1)
End If
Next i
End Sub
use a second array to hold the formula in B. Then iterate both arrays and replace the second with the value where needed:
Sub Test()
With Sheets("Sheet1")
Dim aArr() As Variant
aArr = .Range("A2:A8").Value
Dim bArr() As Variant
bArr = .Range("B2:B8").Formula
Dim i As Long
For i = 1 To UBound(aArr, 1)
If aArr(i, 1) = "X" Then
bArr(i, 1) = aArr(i, 1)
End If
Next i
.Range("B2:B8").Formula = bArr
End With
End Sub
Replace Formulas with Criteria
It is assumed that
the worksheet is in ThisWorkbook, the workbook containing this code,
the Data Column is adjacent to the right of the Criteria Column, which is defined by FirstCellAddress,
the 'search' for the Criteria (X) is case-sensitive i.e. X <> x.
The Code
Option Explicit
Sub replaceFormulasWithCriteria()
Const wsName As String = "Sheet1"
Const FirstCellAddress As String = "A2"
Const Criteria As String = "X"
' Define Criteria Column Range.
Dim rng As Range
With ThisWorkbook.Worksheets(wsName).Range(FirstCellAddress)
Set rng = .Resize(.Worksheet.Cells(.Worksheet.Rows.Count, .Column) _
.End(xlUp).Row - .Row + 1)
End With
' Write values from Criteria Column Range to Criteria Array.
Dim Crit As Variant: Crit = rng.Value
' Define Data Column Range.
Set rng = rng.Offset(, 1)
' Write formulas from Data Column Range to Data Array.
Dim Data As Variant: Data = rng.Formula
Dim i As Long
' Loop through rows of Criteria/Data Column Range.
For i = 1 To UBound(Data, 1)
' Check if Criteria is found in current row in Criteria Array.
If Crit(i, 1) = Criteria Then
' Write Criteria to current row in Data Array.
Data(i, 1) = Criteria
End If
Next i
' Write modified values from Data Array to Data Column Range.
rng.Value = Data
' or:
'rng.Formula = Data
End Sub
I have a quick question: I try to sum up in a table of 4 columns column number 2 if the value in column number 1 AND 3 matches. I found a sample code here on stack overflow, but it counts currently based on column 1. I'm new to VBA and don't know what to change or how to adjust the code to base my calculations on column 1 and 3. Here is the sample code:
Option Explicit
Sub testFunction()
Dim rng As Excel.Range
Dim arrProducts() As String
Dim i As Long
Set rng = Sheet1.Range("A2:A9")
arrProducts = getSumOfCountArray(rng)
Sheet2.Range("A1:B1").Value = Array("Product", "Sum of Count")
' go through array and output to Sheet2
For i = 0 To UBound(arrProducts, 2)
Sheet2.Cells(i + 2, "A").Value = arrProducts(0, i)
Sheet2.Cells(i + 2, "B").Value = arrProducts(1, i)
Next
End Sub
' Pass in the range of the products
Function getSumOfCountArray(ByRef rngProduct As Excel.Range) As String()
Dim arrProducts() As String
Dim i As Long, j As Long
Dim index As Long
ReDim arrProducts(1, 0)
For j = 1 To rngProduct.Rows.Count
index = getProductIndex(arrProducts, rngProduct.Cells(j, 1).Value)
If (index = -1) Then
' create value in array
ReDim Preserve arrProducts(1, i)
arrProducts(0, i) = rngProduct.Cells(j, 1).Value ' product name
arrProducts(1, i) = rngProduct.Cells(j, 2).Value ' count value
i = i + 1
Else
' value found, add to id
arrProducts(1, index) = arrProducts(1, index) + rngProduct.Cells(j, 2).Value
End If
Next
getSumOfCountArray = arrProducts
End Function
Function getProductIndex(ByRef arrProducts() As String, ByRef strSearch As String) As Long
' returns the index of the array if found
Dim i As Long
For i = 0 To UBound(arrProducts, 2)
If (arrProducts(0, i) = strSearch) Then
getProductIndex = i
Exit Function
End If
Next
' not found
getProductIndex = -1
End Function
Sum Column B based on Column A using Excel VBA Macro
Could you please advise me how I can solve this problem. Below you can find a sample picture of my small table. The quantity of the yellow part, for instance, shall be summed up and the second row shall be deleted.
Sample Table - Picture
you said "I try to sum up in a table of 4 columns column number 2" but from your "Sample Table - Picture" I'd understand you want to sum up column number 4
edited after OP variation of data range
Assuming what above you could try the following
Option Explicit
Sub main()
On Error GoTo 0
With ActiveSheet '<== set here the actual sheet reference needed
' With .Range("A:D").Resize(.cells(.Rows.Count, 1).End(xlUp).row) '<== here adjust "A:D" to whatever colums range you need
With .Range("A51:D" & .cells(.Rows.Count, "A").End(xlUp).row) '<== here adjust "A:D" to whatever colums range you need
With .Offset(1).Resize(.Rows.Count - 1)
.Offset(, .Columns.Count).Resize(, 1).FormulaR1C1 = "=SUMIFS(C2, C1,RC1,C3, RC3)" '1st "helper column is the 1st column at the right of data columns (since ".Offset(, .Columns.Count)")
.Columns(2).Value = .Offset(, .Columns.Count).Resize(, 1).Value 'reference to 1st "helper" column (since ".Offset(, .Columns.Count)")
.Offset(, .Columns.Count).Resize(, 1).FormulaR1C1 = "=concatenate(RC1,RC3)"
With .Offset(, .Columns.Count + 1).Resize(, 1) '2nd "helper" column is the 2nd column at the right of data columns (since ".Offset(, .Columns.Count + 1)"
.FormulaR1C1 = "=IF(countIF(R1C[-1]:RC[-1],RC[-1])=countif(C[-1],RC[-1]),1,"""")" 'reference to 1st "helper" column (with all those "C[-1]")
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Offset(, -1).Resize(, 2).ClearContents ' reference to both "helper" columns: ".Offset(, -1)" reference the 1st since it shifts one column to the left from the one referenced in the preceeding "With.." statement (which is the 2nd column at thre right of data columns) and ".Resize(, 2)" enlarges to encose the adjacent column to the right
End With
End With
End With
End With
End Sub
it makes use of two "helper" columns, which I assumed could be the two adjacent to the last data columns (i.e.: if data columns are "A:D" then helper columns are "E:F")
should you need to use different "helper" columns then see comments about how they are located and change code accordingly
I have an excel sheet that is formatted like so:
I would like to format it to be something like this:
It is about 40,000 cells of information, so is there any way to do this that isn't manually?
You could probably use =SUMIF to achieve this, since you appear to have numbers as values.
Create a new sheet, copy column A from your data sheet to your new sheet and remove duplicates. Copy row 1 from your data sheet to your new sheet.
Use this formula in sheet 2 cell B2:
=SUMIF(Sheet1!$A:$A;Sheet2!$A2;Sheet1!B:B)
Drag the formula to the right, then down.
I am by no means an excel expert, and this is going to be my first answer ever. Take this into account please.
I've checked it and it works.
I've add a command button in Sheet1 (where the original data is), and when clicked this code writes formatted data into Sheet2.
No need to manually remove duplicates!
Dim dU1 As Object, cU1 As Variant, iU1 As Long, lrU As Long
Dim MyArray() As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim h As Integer
Private Sub CommandButton1_Click()
'Get unique indexes
Set dU1 = CreateObject("Scripting.Dictionary")
lrU = Cells(Rows.Count, 1).End(xlUp).Row 'number of rows
cU1 = Range("A2:A" & lrU) 'Assuming your data starts in A2
For iU1 = 1 To UBound(cU1, 1)
dU1(cU1(iU1, 1)) = 1
Next iU1
'Now dU1 contains indexes as unique values (about, absence, etc.)
For i = 0 To dU1.Count - 1 'for each index
ReDim MyArray(1 To 1) As Variant 'starts a "new" array
For j = 2 To 9 'each of the columns with values (D1-D8)
a = 0
For k = 2 To lrU 'all rows
If (Worksheets("Sheet1").Cells(k, 1).Value = dU1.keys()(i) And Worksheets("Sheet1").Cells(k, j).Value <> "") Then
MyArray(UBound(MyArray)) = Worksheets("Sheet1").Cells(k, j).Value 'add value to array
ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant 'resize array (now is 1 element longer)
a = a + 1
End If
Next
If a = 0 Then 'if no value found, add an element to array anyway
MyArray(UBound(MyArray)) = "" 'add value to array
ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant 'resize array (now is 1 element longer)
End If
Next
Worksheets("Sheet2").Cells(i + 2, 1) = dU1.keys()(i) 'write indexes in another sheet
For h = 2 To UBound(MyArray)
Worksheets("Sheet2").Cells(i + 2, h) = MyArray(h - 1)
Next
Next
End Sub
I have following Array which stores values found from a search function.
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Else
For Each FoundCell In FoundCells
Array1(i) = FoundCell.Value 'Instead of .Value I can use .Row but .EntireRow doesn't work
i = i + 1
Next FoundCell
j = i - 1
i = 1
End If
I then extract data from the array using transpose which works for '.Value' and '.Row' but I can not extract the whole row from each found value by '.EntireRow'.
Range("A1:A" & UBound(Array1) + 1) = WorksheetFunction.Transpose(Array1)
I tried to change the range in several way's, but nothing seem to fit the .EntireRow criteria.
Update after comment from loannis:
How can I use EntireRow in my array to transpose all the rows to a target location based on the search results stored in FoundCell?
I am using the FindAll search function from cpearson http://www.cpearson.com/excel/findall.aspx
You can extract an entire row like this however it is a two dimensional array.
Sub MethodName()
Dim Array1
'Get all the cell values in row A
Array1 = Cells(1, 1).EntireRow
Dim i As Integer
'loop through the array and output the contents to the 2nd row
For i = 1 To UBound(Array1, 2)
Cells(2, i).Value = Array1(1, i)
Next i
End Sub
I came to the conclusion that for the purpose of which I am doing this for, I might as well scrap the array and do it like this:
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Else
For Each FoundCell In FoundCells
FoundCell.EntireRow.Copy Worksheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next FoundCell
End If