I've got an array of a range of cells and I need to write it back to a specific range of cells. My first 2 columns are working as desired when writing back to the new range of cells but the next 2 columns are mirroring column 2 for columns 3 and 4.
Array Range:
1,2,3,4
2,2,3,5
3,4,5,6
will write as:
1,2,2,2
2,2,2,2
3,4,4,4
What I want is:
1,2,3,4
2,2,3,5
3,4,5,6
Dim myRange As Range
Dim scriptDic As Variant
Dim arr As Variant
Dim i As Integer
Dim x As Integer
With ThisWorkbook.Sheets("AGGREGATE")
Set myRange = .Range("H4:K19")
Set scriptDic = CreateObject("Scripting.Dictionary")
arr = myRange.Value
For i = 1 To UBound(arr, 1)
If arr(i, 1) <> "" Then
scriptDic(arr(i, 1)) = scriptDic(arr(i, 1)) + arr(i, 2)
End If
Next
Application.ScreenUpdating = False
.Range("M4:P19").ClearContents
myRange.Range("F1").Resize(scriptDic.Count, 1) = Application.WorksheetFunction.Transpose(scriptDic.keys)
myRange.Range("G1").Resize(scriptDic.Count, 1) = Application.WorksheetFunction.Transpose(scriptDic.items)
myRange.Range("H1").Resize(scriptDic.Count, 1) = Application.WorksheetFunction.Transpose(scriptDic.items)
myRange.Range("I1").Resize(scriptDic.Count, 1) = Application.WorksheetFunction.Transpose(scriptDic.items)
Application.ScreenUpdating = True
End With
I am assuming that it has to do with this section but I'm not very good with dimensional arrays.
For i = 1 To UBound(arr, 1)
If arr(i, 1) <> "" Then
scriptDic(arr(i, 1)) = scriptDic(arr(i, 1)) + arr(i, 2)
End If
Any help would be much appreciated!
For this purpose, I would get rid of the Dictionary, and just use RemoveDuplicates to obtain the unique key values. Then I would use SUMIF to get the desired answers:
Sub test()
Dim numRows As Long
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("AGGREGATE")
'Clear existing contents of column M:P
.Range("M4", .Cells(.Rows.Count, "M").End(xlUp).Offset(0, 3)).ClearContents
'Copy keys to column M
numRows = .Cells(.Rows.Count, "H").End(xlUp).Row - 3
.Range("M4").Resize(numRows, 1).Value = .Range("H4").Resize(numRows, 1).Value
'Generate unique list
.Range("M4").Resize(numRows, 1).RemoveDuplicates Columns:=1, Header:=xlNo
'Calculate answers in column N to P
numRows = .Cells(.Rows.Count, "M").End(xlUp).Row - 3
.Range("N4").Resize(numRows, 3).Formula = "=SUMIF($H:$H,$M4,I:I)"
'Convert formulas to values
.Range("N4").Resize(numRows, 3).Value = .Range("N4").Resize(numRows, 3).Value
End With
Application.ScreenUpdating = True
End Sub
Related
I currently have the following codes that look up the column for Columbus. But how do I specify that I only want to look up the column for Columbus in Ohio by also referring to row 4 (State)?
Amount = WorksheetFunction.Match("Columbus", Rows("5:5"), 0)
Try Looping thru all the records -
Dim Amount As Variant
Dim lngRow as long
lngRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lngRow 'Considering row 1 has headers
If ActiveSheet.Cells(i, 5) = "Columbus" And ActiveSheet.Cells(i, 4) = "Ohio" Then
Amount = i
Exit For
End If
Next i
Thanks
Use Variant Arrays and cycle through that it will be quicker:
With Worksheets("Sheet1") 'Change to your sheet
Dim rngArr() As Variant
rngArr = .Range(.Cells(4, 1), .Cells(5, .Columns.Count).End(xlToLeft)).Value
Dim i As Long
For i = 1 To UBound(rngArr, 2)
If rngArr(1, i) = "Ohio" And rngArr(2, i) = "Columbus" Then Exit For
Next i
If i <= UBound(rngArr, 2) Then
Dim Amount As Long
Amount = i
Else
MsgBox "Not Found"
End If
End With
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
Have data spread across columns
Want to keep the first three columns fixed (columns a, b and c).
And convert columns from four onward into new rows (columns d --> last column where there is a value).
Example:
The colours from columns D -->onwards are NOT always green, blue, black red, etc.... they vary depending on the data loaded in from a power query table.
This is how I want the data to look:
Notice how columns A, B and C are fixed with the same info and only columns D onwards is recreating a new "row".
I've been trying to adapt a VBA script from a previous post on here, but I'm having some complications. I'm also trying to keep it on the sheet that the data is currently on, not create a new sheet. If it is easier to just create a new sheet.. then I can work with that.. Script:
Sub ColumnTorow()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
With ActiveSheet
Dim rRow As Long
rRow = 2
Dim row As Long
row = 2
Dim col As Integer
Do While True
col = 2
Do While True
If data(row, col) = "" Then Exit Do 'Skip Blanks
.Cells(rRow, 1).Value = data(row, 1)
.Cells(rRow, 2).Value = data(row, col)
rRow = rRow + 1
If col = maxCols Then Exit Do 'Exit clause
col = col + 1
Loop
If row = maxRows Then Exit Do 'exit cluase
row = row + 1
Loop
End With
End Sub
This is just an example code that I was provided with and I'm trying to modify... It might not even be the correct solution to this problem but figured I would post it anyways.
Here you go, since I did this yesterday, I got it together fairly quickly:
Sub ColumnToRow()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
Dim newSht As Worksheet
Set newSht = Sheets.Add
With newSht
.Cells(1, 1).Value = data(1, 1)
.Cells(1, 2).Value = data(1, 2)
.Cells(1, 3).Value = data(1, 3)
.Cells(1, 4).Value = data(1, 4)
Dim writeColumn As Double
writeColumn = 1
Dim writeRow As Double
writeRow = 2
Dim row As Double
row = 2
Do
writeColumn = 1
Dim col As Double
col = 4
Do While True
If data(row, col) <> "" Then
Dim firstColData As String
firstColData = data(row, 1)
.Cells(writeRow, writeColumn) = firstColData
writeColumn = 2
Dim secondColData As String
secondColData = data(row, 2)
.Cells(writeRow, writeColumn) = secondColData
writeColumn = 3
Dim thirdColData As String
thirdColData = data(row, 3)
.Cells(writeRow, writeColumn) = thirdColData
writeColumn = 4
.Cells(writeRow, writeColumn).Value = data(row, col)
writeColumn = 1
writeRow = writeRow + 1
End If
If col = maxCols Then
Exit Do 'Exit clause
End If
col = col + 1
Loop
If row = maxRows Then
Exit Do 'exit cluase
End If
row = row + 1
Loop While True
End With
End Sub
consider this code.
Sub TransData()
Dim vDB, vR()
Dim n As Long, i As Long, j As Integer, k As Integer
vDB = Range("a1").CurrentRegion
For i = 2 To UBound(vDB, 1)
For j = 4 To UBound(vDB, 2)
If vDB(i, j) <> "" Then
n = n + 1
ReDim Preserve vR(1 To 4, 1 To n)
For k = 1 To 3
vR(k, n) = vDB(i, k)
Next k
vR(4, n) = vDB(i, j)
End If
Next j
Next i
Sheets.Add
Range("a1").Resize(1, 4) = Array("Item", "Amount", "Price", "Color")
Range("a2").Resize(n, 4) = WorksheetFunction.Transpose(vR)
End Sub
a report I pull gives me an excel spreadsheet that splits the data for each entry across three rows in excel. I'm trying to figure out the best way to combine the three rows into one row so each field is in it's own column.
Each three row cluster is separated by a blank row and each of the data rows has five columns. The first cluster starts on row 4.
I have a macro (shown below) that does this correctly, but not efficiently. The spreadsheets I get have many (up to a million) rows in them.
I was originally using the cut and paste commands and that was really slow. I found that directly setting .value make it quite a bit faster but this is still way to slow.
I think that the right answer is to do all of the manipulation in memory and write to the actual excel range only once, but I'm at the limits of my VBA foo.
Option Explicit
Sub CombineRows()
Application.ScreenUpdating = False
Dim currentRow As Long
Dim lastRow As Long
Dim pasteColumn As Long
Dim dataRange As Range
Dim rowEmpty As Boolean
Dim firstOfGroup As Boolean
Dim data As Variant
Dim rw As Range
pasteColumn = 6
rowEmpty = True
firstOfGroup = True
currentRow = 4
lastRow = 30
Set dataRange = Range(Cells(currentRow, 1), Cells(lastRow, 5))
For Each rw In dataRange.Rows
Debug.Print rw.Row
If WorksheetFunction.CountA(Range(Cells(rw.Row, 1), Cells(rw.Row, 5))) = 0 Then
If rowEmpty Then Exit For
currentRow = rw.Row + 1
rowEmpty = True
Else
If Not rowEmpty Then
Range(Cells(currentRow, pasteColumn), Cells(currentRow, pasteColumn + 4)).value = Range(Cells(rw.Row, 1), Cells(rw.Row, 5)).value
Range(Cells(rw.Row, 1), Cells(rw.Row, 5)).value = ""
Debug.Print "pasteColumn:"; pasteColumn
If pasteColumn = 6 Then
pasteColumn = 11
ElseIf pasteColumn = 11 Then
pasteColumn = 6
End If
End If
rowEmpty = False
End If
Next
Application.ScreenUpdating = True
End Sub
Update: After I posted this, I noticed that I still had those Debug.Print statements in there. Once I removed those, the performance improved from execution times on the order of hours to a minute or two.
I still thing that this is unnecessarily slow so I'm still interested in any answer that can explain the right way to minimize the VBA <-> excel interactions.
If I understand correctly your question, you want to copy some data.
I recommend you to use an array.
Sub data()
Dim data() As String 'Create array
Dim column as integer
column = 0
For i = 0 To 100000 'See how many columns are in the line
If IsEmpty(Cells(rowNum, i+1)) = False Then
column = column + 1
Else
Exit For
End If
Next
ReDim date(column) As String 'Recreat the array, with the excat column numer
For i = 0 To column - 1
data(i, j) = Cells(rowNum, i + 1) 'Puts data into the array
Next
End sub()
And now you just have to insert the data from the array to the correct cell.
#Cubbi is correct. You can use an array to do all of your data manipulation and then write to the worksheet only once at the end. I've adapted your code to use an array to combine the three rows into a single row for each of the groups. Then at the end it selects "Sheet2" and pastes in the collected data. Note, this is not an in-place solution like yours, but it is super fast:
Option Explicit
Sub AutitTrailFormat()
Application.ScreenUpdating = False
Dim dataArray() As String
Dim currentRow As Long
Dim lastRow As Long
Dim pasteColumn As Long
Dim dataRange As Range
Dim rowEmpty As Boolean
Dim firstOfGroup As Boolean
Dim data As Variant
Dim rw As Range
Dim i, j, k As Long
Dim Destination As Range
pasteColumn = 6
rowEmpty = True
firstOfGroup = True
currentRow = 4
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet1").Select
Set dataRange = Worksheets("Sheet1").Range(Cells(currentRow, 1), Cells(lastRow, 5))
data = dataRange.Value
ReDim dataArray(UBound(data, 1), 15)
j = 1
k = 1
For i = 1 To UBound(data, 1)
If data(i, 1) = "" And data(i, 2) = "" And data(i, 3) = "" And data(i, 4) = "" And data(i, 5) = "" Then
j = j + 1
k = 1
Else
dataArray(j, k + 0) = data(i, 1)
dataArray(j, k + 1) = data(i, 2)
dataArray(j, k + 2) = data(i, 3)
dataArray(j, k + 3) = data(i, 4)
dataArray(j, k + 4) = data(i, 5)
k = k + 5
End If
Next
Worksheets("Sheet2").Select
Set Destination = Worksheets("Sheet2").Range(Cells(1, 1), Cells(UBound(dataArray, 1), 16))
Destination.Value = dataArray
Application.ScreenUpdating = True
End Sub
I'm trying to remove the blank records from a combobox with two lists.
This is my code:
Private Sub UserForm_Initialize()
Dim N As Range
Dim LastRow As Integer
Dim ws As Worksheet
PREST.ColumnCount = 2
Set ws = Worksheets("L_Location")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim i, j As Integer
Dim location(2 To 100, 1 To 2) As String
For j = 1 To 2
For i = 2 To LastRow
If ws.Cells(i, j).Value <> vbNullString Then
location(i, j) = ws.Cells(i, j).Value
End If
Next i
Next j
PREST.List = location
End Sub
I don't know what I'm doing wrong.
You are having blanks because your 2D array is already sized with 100 rows. A simple workaround would be to first count the non-empty rows, then dimension the Array accordingly.
Dim location() As String
Dim count As Long
count = Range("A2:A" & LastRow).SpecialCells(xlCellTypeConstants).Cells.count
ReDim location(1 To count, 1 To 2)
'then continue from here to fill the array
This code will fill the combobox with your range value then will delete any empty item:
Private Sub UserForm_Initialize()
Dim LastRow As Long
Dim ws As Worksheet
PREST.ColumnCount = 2
Set ws = Worksheets("L_Location")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim i As Long ', j As Integer
PREST.List = ws.Range("a1:b" & LastRow).Value
For i = PREST.ListCount - 1 To 0 Step -1
If PREST.List(i) = "" Then PREST.RemoveItem i
Next
End Sub
I tried this :
Dim location() As String
ReDim location(LastRow - 2, 1)
For j = 0 To 1
For i = 0 To LastRow - 2
If ws.Cells(i + 2, j + 1).Value <> vbNullString And ws.Cells(i + 2, j + 1).Value <> "" Then
location(i, j) = ws.Cells(i + 2, j + 1).Value
End If
Next i
Next j
PREST.List = location
which seems to work but i guess its gonna give me an error if the list is empty (lastrow = 1)
Since you say that any two cells on the same row are both either blank or with values, then you could go like follows:
Dim cell As Range
Dim i As Long, j As Long
PREST.ColumnCount = 2
With Worksheets("L_Location") '<--| reference your worksheet
With .Range("A2", .Cells(.Rows.Count,1).End(xlUp)).SpecialCells(xlCellTypeConstants) '<--| reference its column A not empty cells from row 1 down to last not empty one
Dim location(1 To .Count, 1 To 2) As String '<--| size your array rows number to that of referenced cells
For Each cell In .Cells '<--| loop through referenced cells
i = i + 1 '<--| update array row index
For j = 1 To 2 '<--| loop through array columns
location(i, j) = cell.Offset(j -1).Value '<--| fill array
Next j
Next cell
End With
End With
PREST.List = location