Goal: I want to build 4 different strings with method Contagenation. I have a dynamic count of columns (column 4 to maxCol) in each of 4 rows (row 32 to row 35) in sheet ("Calc"). The 4 different strings should be stored in another sheet ("CreateColumns")in cells (A1, A2, A3, A4)
Problem: I have coded the following code to achieve that goal but in sheet ("CreateColumns") each of the 4 rows are filled with the same value = last value of row 35 in sheet("Calc") and not with the 4 different values as intended.
Question: What is the error in my code?
Sub CreateColumns()
Dim maxCol As Integer
Dim x As String
Dim rng As Range
Dim cel As Range
Dim i As Long
Dim row As Long
Dim y As Long
Sheets("Calc").Select
maxCol = Cells(32, columns.Count).End(xlToLeft).column
For row = 32 To 35
Sheets("Calc").Select
Cells(row, 4).Activate
For i = 4 To maxCol
With Worksheets("Calc")
Set rng = Range(.Cells(row, 4), .Cells(row, maxCol))
End With
x = ""
For Each cel In rng
x = x & cel.Value
For y = 1 To 4
Sheets("ColCreate").Cells(y, 1).Value = x
Next
Next
Next
Next
End Sub
The issue in your code is that the part where you paste to sheet "ColCreate" is a bit out of place - it should occur once for each occurence of your outermost loop, alongside the "y" increment
I have slightly amended your code below, should provide the expected result
Sub CreateColumns()
Dim maxCol As Integer
Dim x As String
Dim rng As Range
Dim cel As Range
Dim i As Long
Dim row As Long
Dim y As Long
Sheets("Calc").Select
maxCol = Cells(32, Columns.count).End(xlToLeft).Column
y = 1
For row = 32 To 35
Sheets("Calc").Select
Cells(row, 4).Activate
For i = 4 To maxCol
With Worksheets("Calc")
Set rng = Range(.Cells(row, 4), .Cells(row, maxCol))
End With
x = ""
For Each cel In rng
x = x & cel.Value
Next
Next
Sheets("ColCreate").Cells(y, 1).Value = x
y = y + 1
Next
End Sub
Related
I am working on a dynamic worksheet which the total rows and columns of content will be changing.
What I try to do is, making an active cell going through the worksheet. It starts from the very last column that has content (I used UsedRange here), and from the 7st row down to the last row not blank.
When 1) The active cell has a color filling of index 16 or 36; 2) The active cell has no value, the cell will fetch the value storing in the matching row E.
The loop will end when hitting column E (I haven't been able to go that far yet).
I will attach my code below for all possible help, since it complies but does not return any result...Thank you again!
Sub catchCurrentAutomated()
Dim column As Integer
Dim row As Integer
Dim Cell As Range
row = 7
column = ActiveSheet.UsedRange.Columns.Count
Set Cell = ActiveCell
While range("A" & row) <> ""
If Cell.Interior.ColorIndex = 16 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
ElseIf Cell.Interior.ColorIndex = 36 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
End If
row = row + 1
column = column - 1
Wend
End Sub
Something like this should work (untested)
Sub catchCurrentAutomated()
Dim col As Long '<< use Long not Integer
Dim row As Long
Dim c As Range, ws As Worksheet, lr As Long, indx
Set ws = ActiveSheet
col = ws.UsedRange.Columns.Count
lr = ws.Cells(Rows.Count, 1).End(xlUp).row 'last occupied cell in ColA
Do While col > 5
For row = 7 To lr
With ws.Cells(row, col)
indx = .Interior.Color.Index
If (indx = 16 Or indx = 36) And Len(.Value) = 0 Then
.Value = ws.Cells(row, "E").Value
End If
End With
Next row
col = col - 1 'next column to left
Loop
End Sub
I want to match rows from two different sheets and highlight only in the first column of the unmatched row or better still copy the unmatched rows into a new sheet. The code should compare the rows of the two Sheets and color the new rows in the second sheet. Sheet2 (say Jan 2020) contains more rows than Sheet1 (Dec 2019) as its the recently updated sheet and they both contain rows of over 22k with both having unique ID as the first column.
My below code tries to highlight all the unmatching cells and takes longer time to finish. What I wish is for the code to just color the unmatched in column A (the vb.Red) only(since its the unique ID) while ignoring the rest of the column/cells (vb.Yellow) and or if possible copy the highlighted rows into a new sheet.
Sub RunCompare()
Call compareSheets("Sheet1", "Sheet2") 'compareSheets("2019-01 Database", "2019-02 Database")
End Sub
Sub compareSheets(shtSheet1 As String, shtSheet2 As String)
Dim c As Integer, j As Integer, i As Integer, mydiffs As Integer, cnt1 As Integer, cnt2 As Integer
Dim noexist As Integer
cnt2 = Worksheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell).Row
cnt1 = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row
'For each cell in sheet2 that is not the same in Sheet1, color it yellow
For i = 1 To cnt2
For j = 1 To cnt1
If ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, 1).Value Then
For c = 2 To 22
If Not ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, c).Value Then
ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
Next
Exit For
End If
If j = cnt1 Then
ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Interior.Color = vbRed
End If
Next
Next
'Display a message box to demonstrate the differences and if there is a new entry on the second sheet
'MsgBox mydiffs & ":differences found, " & noexist & ":no exist", vbInformation
ActiveWorkbook.Sheets(shtSheet2).Select
End Sub
Let's simplify the task and do it step by step.
This is how the input in the two sheets can look like:
Then, we may consider reading these and saving them to an array:
Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")
Dim arrayA As Variant
Dim arrayB As Variant
With Application
arrayA = .Transpose(.Transpose(rangeA))
arrayB = .Transpose(.Transpose(rangeB))
End With
Looping between the data in the two arrays is quite fast in vba. The writing to the third worksheet is done only once the two values from the two arrays match:
Dim myValA As Variant
Dim myValB As Variant
Dim currentRow As Long: currentRow = 1
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
currentRow = currentRow + 1
End If
Next
Next
This is the result in the third worksheet, all matching values are in a single row:
This is how the whole code looks like:
Sub CompareTwoRanges()
Dim rangeA As Range
Dim rangeB As Range
Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")
Dim arrayA As Variant
Dim arrayB As Variant
With Application
arrayA = .Transpose(.Transpose(rangeA))
arrayB = .Transpose(.Transpose(rangeB))
End With
Dim myValA As Variant
Dim myValB As Variant
Dim currentRow As Long: currentRow = 1
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
currentRow = currentRow + 1
End If
Next
Next
End Sub
Note - there will be another performance bonus, if the results are written to an array and then written from the array to the worksheet. Thus the writing would happen only once. This is the change, that needs to be implemented in the code, after the array declarations:
Dim myValA As Variant
Dim myValB As Variant
Dim resultArray() As Variant
ReDim Preserve resultArray(2 ^ 20)
Dim i As Long: i = 0
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
resultArray(i) = myValA
i = i + 1
End If
Next
Next
ReDim Preserve resultArray(i)
ThisWorkbook.Worksheets(3).Cells(1, 1).Resize(UBound(resultArray)) = Application.Transpose(resultArray)
when you get cell value, it spends time.
so, you can target Range transfer 2d Variant
Dim endRow AS Long
Dim olderRange AS Range
Dim olderVariant AS Variant
endRow = olderSheet.cells(rows.count,1).end(xlup).row
Set olderRange = olderSheet.Range(olderSheet.Cells(startRow, startCol), olderSheet.Cells(endRow, endCol))
'Transfer
olderVariant = olderRange
For currentRow = 1 to UBound(olderVariant, 1)
'Loop
'if you want change real Cell value Or interior
'add row Or Col weight
if olderVariant(currentRow, currentCol) = newerVariant(currentRow, currentCol) THen
newerSheet.Cells(currentRow+10,currentCol+10).interior.colorIndex = 3
End if
Next currentRow
In case anyone has the same kind of problem, I have found an easier way to do it. Providing your sheet2 is the comparison sheet:
Dim Ary1 As Variant, Ary2 As Variant
Dim r As Long
Ary1 = Sheets("Sheet1").UsedRange.Value2
Ary2 = Sheets("Sheet2").UsedRange.Value2
With CreateObject("scripting.dictionary")
For r = 1 To UBound(Ary1)
.Item(Ary1(r, 1)) = Empty
Next r
For r = 1 To UBound(Ary2)
If Not .Exists(Ary2(r, 1)) Then Sheets("Sheet2").Cells(r, 1).Interior.Color = vbRed
Next r
End With
I have a spreadsheet with approx. 45,000 rows. Currently I am looping through a column and targeting any cells with a value of 0. Those row numbers get stored in an array. I am then looping through that array, and changing another cell based on the array value. I have 5000 rows with values that need to be reassigned, and it is taking over an hour to run that segment of the code (saving the row numbers to the array only takes a few seconds). Any ideas on how to get the code to run faster? Here is the code:
'Initialize array
Dim myArray() As Variant
Dim x As Long
'Looks for the last row on the "Dates" sheet
Dim lastRow As Long
With ThisWorkbook.Sheets("Dates")
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
End With
Dim i As Integer
i = 2
Dim uCounter As Integer
'Loop through all the dates on the "Dates" sheet
While i <= lastRow
'Each date has a counter next to it
uCounter = Worksheets("Dates").Range("B" & i).Value
Dim uDate As String
'Store the date as a string
uDate = Worksheets("Dates").Range("C" & i).Value
Dim startRow As Long, endRow As Long
'Finds the first and last instance of the date on the CERF Data page (45,000 rows)
With Sheets("CERF Data")
startRow = .Range("AN:AN").Find(what:=uDate, after:=.Range("AN1"), LookIn:=xlValues).Row
endRow = .Range("AN:AN").Find(what:=uDate, after:=.Range("AN1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row
End With
Dim j As Long
For j = startRow To endRow
'If the cell in column BB is 0, and the counter is above 0 save row number to array, j being the variable representing row number
If Sheets("CERF Data").Range("BB" & j).Value = 0 And uCounter > 0 Then
'save row number to array
ReDim Preserve myArray(x)
myArray(x) = j
x = x + 1
'decrement counter by 1
uCounter = uCounter - 1
End If
If uCounter = 0 Then Exit For
Next j
i = i + 1
Wend
Dim y As Long
'Loop through the array and assign a value of 2 to all the rows in the array for column AS
For y = LBound(myArray) To UBound(myArray)
Sheets("CERF Data").Range("AS" & myArray(y)).Value = 2
Next y
Thanks!
Without more info this is what I can get you:
Just 1 loop through all the rows, once, checking both if the value on column BB = 0 and the date is within your range of dates:
Option Explicit
Sub Test()
Dim arr, i As Long, DictDates As Scripting.Dictionary
arr = ThisWorkbook.Sheets("CERF Data").UsedRange.Value
Set DictDates = New Scripting.Dictionary 'You need the Microsoft Scripting Runtime Reference for this to work
'Create a dictionary with all the dates you must check
With ThisWorkbook.Sheets("Dates")
LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
For i = 2 To LastRow
If Not DictDates.Exists(CDate(.Cells(i, 3))) Then DictDates.Add CDate(.Cells(i, 3)), 1
Next i
End With
'Only one loop through the whole array
For i = 1 To UBound(arr)
If arr(i, 54) = 0 And DictDates.Exists(CDate(arr(i, 40))) Then 'check your 2 criterias, date and value = 0
arr(i, 45) = 2 'input the value 2 on the column "AS"
End If
Next i
ThisWorkbook.Sheets("CERF Data").UsedRange.Value = arr
End Sub
How can I run a loop in VBA so that the sequence looks like in green an pink color?
Because when I use this code is actually just paste all number 1. not increase.
ThisWorkbook.Sheets("Main").Range("E2:E" & iLast).FillDown
This may not be the cleanest way, but it will do the trick.
Sub InsertSequenceAndColours()
Dim ws As Worksheet
Dim rng As Range
Dim iLast As Integer
Dim i As Integer
Dim iSeq As Integer
Dim iColRGB(2, 3) As Integer
Dim iIncremColour As Integer 'used to determine the colour to use
Dim iColour As Integer
'set RGB Colours; change as needed
'colour 0 (green)
iColRGB(0, 1) = 146
iColRGB(0, 2) = 208
iColRGB(0, 3) = 80
'colour 1 (pink)
iColRGB(1, 1) = 255
iColRGB(1, 2) = 225
iColRGB(1, 3) = 236
'change to 0 if you want to start with colour 1 (pink)
iIncremColour = 1
'declare worksheet to work on
Set ws = ThisWorkbook.Worksheets(Sheet1.Name)
With ws
'find last row
iLast = .Cells(.Rows.Count, "C").End(xlUp).Row
'loop through column C
For i = 2 To iLast
iSeq = iSeq + 1
If .Cells(i, 3).Value <> .Cells(i - 1, 3).Value Then
iSeq = 1
iIncremColour = iIncremColour + 1
End If
'assign Seq. No. to cell (column E)
.Cells(i, 5).Value = iSeq
'find if iIncremColor is odd or even. output: 0 or 1
iColour = iIncremColour Mod 2
'assign colour to col C D E
.Range(Cells(i, 3), Cells(i, 5)).Interior.Color = _
RGB(iColRGB(iColour, 1), iColRGB(iColour, 2), iColRGB(iColour, 3))
Next i
End With
End Sub
It finds out the Seq "1" (Col E) by finding the first occurrence of "No" (Col C); Seq "2, 3" are just incremental (so it will work also with more than 3 occurrences).
Same with colour. For each "Seq 1" it increments a number; by checking if this number is odd or even it assign one colour or the other.
Please Note I use worksheet codename to work (if you're not familiar with it, please google it), which I strongly advise since it will work even if you decide to change the name of your worksheet in excel.
When VBA requests to work with worksheet name or index, you can trick it by using codename.Name or codename.Index.
Approach via array
You can fill an array and write it back to your target range:
Sub FlexibleRange()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Main") ' << change to your sheet name
Dim start As Long, last As Long, i As Long ' declare variables
start = 2: last = 100 ' <~~ change to your individual rows
Dim v: ReDim v(start To last, 1 To 1) ' variant datafield array, counter
For i = start To last
v(i, 1) = (i - start) Mod 3 + 1 ' assign values
Next i
ws.Range("E" & start & ":E" & last) = v ' write numbers to column E
End Sub
I got to solve it.
i use this formula
=MOD(ROW()-2,3)+1.
Thank's you all..appreciate your help. <3
I am trying to make edge relation from excel file which are organized in rows,
A,B,C,
D,E
the aim is to create relationships from each row:
A,B
A,C
B,C
I have the following codes , the problem is the codes is efficient when rows are equal in length but for example for above rows it create also following edges (relationship):
D," "
E, " "
Which create big problem for large data set. I was wondering if some body can help me to adjust the code the way to create the edge list only till filled cells in each row. If there is any other way to do this more efficient will appreciate it.
Thank you so much,Will be great help.
My code:
Sub Transform()
Dim targetRowNumber As Long
targetRowNumber = Selection.Rows(Selection.Rows.Count).Row + 2
Dim col1 As Variant
Dim cell As Range
Dim colCounter As Long
Dim colCounter2 As Long
Dim sourceRow As Range: For Each sourceRow In Selection.Rows
For colCounter = 1 To Selection.Columns.Count - 1
col1 = sourceRow.Cells(colCounter).Value
For colCounter2 = colCounter + 1 To Selection.Columns.Count
Set cell = sourceRow.Cells(, colCounter2)
If Not cell.Column = Selection.Column Then
Selection.Worksheet.Cells(targetRowNumber, 1) = col1
Selection.Worksheet.Cells(targetRowNumber, 2) = cell.Value
targetRowNumber = targetRowNumber + 1
End If
Next colCounter2
Next colCounter
Next sourceRow
End Sub
I've played around with it - this should do the trick. We can probably speed it up by outputting to another variant array if needed, but this ran pretty quickly for me:
Sub Transform_New()
Dim rngSource As Range, rngDest As Range
Dim varArray As Variant
Dim i As Integer, j As Integer, k As Integer
Set rngSource = Sheet1.Range("A1", Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1)) 'Put all used rows into range
Set rngDest = Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1).Offset(2, 0) 'Set target range to start 2 below source range
varArray = Range(rngSource, rngSource.Offset(0, Range("A1").SpecialCells(xlCellTypeLastCell).Column)).Value
For i = LBound(varArray, 1) To UBound(varArray, 1) 'Loop vertically through array
For j = LBound(varArray, 2) To UBound(varArray, 2) 'Loop horizontally through each line apart from last cell
k = j
Do Until varArray(i, k) = ""
k = k + 1
If varArray(i, k) <> "" Then
rngDest.Value = varArray(i, j)
rngDest.Offset(0, 1).Value = varArray(i, k)
Set rngDest = rngDest.Offset(1, 0)
End If
Loop
Next
Next
End Sub