I am trying to make a code to loop the column b and then fill column c based on if its empty or not but its not working when I set the data into the middel of the excel sheet
Sub FillCellFromAbove()
Dim x As Integer
Dim y As Integer
y = Application.WorksheetFunction.Count(Range("B:B")) + 1
For x = 1 To y
Range("C3:C7" & x).Select
If Range("B" & x) = "" Then
ActiveCell.Value = "Yes"
ElseIf Range("B" & x) <> "" Then
ActiveCell.Value = "NO"
End If
Next x
End Sub
Range("C3:C7" & x).Select is selecting a range starting at C3 and ending at C71 for the first loop and C72 for the second. Doubt that is what you want.
Also COUNT only counts the cells with numbers not the cells in a range from the first cell with a value to the last. So in this case you would return 4 and do 4 loops.
Use:
Sub FillCellFromAbove()
Dim x As Long
Dim y As Long
With ActiveSheet 'Better to set actual sheet
y = .Cells(.Rows.Count,2).End(XlUp).Row
For x = 3 To y
If .Cells(x,2) <> "" Then
.Cells(x,3) = "Yes"
Else
.Cells(x,3) = "No"
End If
Next x
End With
End Sub
Flag Empty and Non-Empty Using Evaluate
Sub FlagEmptyNonEmpty()
Const SourceColumn As String = "B"
Const DestinationColumn As String = "C"
Const YesFlag As String = "Yes"
Const NoFlag As String = "No"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
With Intersect(ws.UsedRange, ws.Columns(SourceColumn))
.EntireRow.Columns(DestinationColumn).Value _
= ws.Evaluate("IF(ISBLANK(" & .Address(0, 0) & "),""" _
& YesFlag & """,""" & NoFlag & """)")
End With
End Sub
Related
I have a table in an active worksheet.
I am trying to:
Scan Columns(A:M) of Row 6 to see if all cells are empty
If yes, then scan Columns (N:R) of Row 6 to see if all cells are empty
If 2. is false, then copy above row's Columns (A:I) in Row 6
Repeat 1-3 but on Row 7
This process should repeat until the rows of the table end.
I would like to incorporate ActiveSheet.ListObjects(1).Name or something similar to duplicate the sheet without having to tweak the code.
How I can make this as efficient and as risk free as possible? My code works but it's really too much.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim y As Long
Dim a As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
a = 0
For x = 6 To lr
For y = 1 To 13
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
If a = 0 Then
For y = 14 To 18
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
Else
a = 0
End If
If a <> 0 Then
For y = 1 To 13
Cells(x, y).Value = Cells(x - 1, y).Value
Next y
End If
a = 0
Next x
End Sub
This is the final code based on #CHill60 code. It got me 99% where I wanted.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range, r3 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
'check columns A to M for this row are empty
Set r = ActiveSheet.Range("A" & CStr(x) & ":M" & CStr(x))
'check columns N to R for this row are empty
Set r2 = ActiveSheet.Range("N" & CStr(x) & ":R" & CStr(x))
If WorksheetFunction.CountA(r) = 0 And WorksheetFunction.CountA(r2) <> 0 Then
'copy the data into columns A to M
Set r3 = ActiveSheet.Range("A" & CStr(x) & ":I" & CStr(x))
r3.Value = r3.Offset(-1, 0).Value
End If
Next x
End Sub
Instead of looking at individual cells, look at Ranges instead. Consider this snippet of code
Sub demo()
Dim x As Long
For x = 6 To 8
Dim r As Range
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
Debug.Print r.Address, MyIsEmpty(r)
Next x
End Sub
I have a function for checking for empty ranges
Public Function MyIsEmpty(rng As Range) As Boolean
MyIsEmpty = WorksheetFunction.CountA(rng) = 0
End Function
I use this because the cell might "look" empty, but actually contain a formula.
Note I've explicitly said which sheet I want the Cells from - users have a habit of clicking places other than where you think they should be! :laugh:
Edit after OP comment:
E.g. your function might look like this
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
a = 0
'check columns A to M for this row are empty
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
If Not MyIsEmpty(r) Then
a = a + 1
End If
If a = 0 Then
'check columns N to R for this row are empty
Set r2 = Sheets(1).Range("N" & CStr(x) & ":R" & CStr(x))
If Not MyIsEmpty(r2) Then
a = a + 1
End If
Else
a = 0
End If
If a <> 0 Then
'copy the data into columns A to M
'You might have to adjust the ranges here
r.Value = r2.Value
End If
Next x
End Sub
where you have a source range and a target range - you appear to be putting the values in the previous row so my value of r is probably wrong in this example - you could use r.Offset(-1,0).Value = r2.Value
I'm also not sure what you are trying to do with the variable a If that is meant to be a "flag" then consider using a Boolean instead - it only has the values True or False
I have 3 sheets that need to check if they have same value. All value on column B6 until last row should be same in Sheets MM, PP and CO. If there's difference value, the different value should be on highlight (the color is red).
But, my syntax didn't run. The syntax just can read if there's an empty column in range. This is my syntax.. Not including highlight. First, i tried to place the difference value to the other sheets. But, failed. Thank you.
Sub MatchValue()
Dim x As Integer
Dim y As Integer
Dim z As Integer
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row
x = ActiveWorkbook.Worksheets("MM").Range("B6:B" & LastRowB).Cells.SpecialCells(xlCellTypeConstants).Count
y = ActiveWorkbook.Worksheets("PP").Range("B6:B" & LastRowB).Cells.SpecialCells(xlCellTypeConstants).Count
z = ActiveWorkbook.Worksheets("CO").Range("B6:B" & LastRowB).Cells.SpecialCells(xlCellTypeConstants).Count
If x <> y Then
MsgBox "MM <> PP", vbCritical, "Error Report"
End If
If y <> z Then
MsgBox "PP <> CO", vbCritical, "Error Report"
End If
If z <> x Then
MsgBox "CO <> MM", vbCritical, "Error Report"
End If
SheetMM = "MM"
DataColumnMM = "B6"
SheetPP = "PP"
DataColumnPP = "B6"
SheetCO = "CO"
DataColumnCO = "B6"
SheetUnmatched = "Data Unmatched"
DataColumnUnmatched = "A1"
DataRowMM = Range(DataColumnMM).Row
DataColMM = Range(DataColumnMM).Column
DataRowPP = Range(DataColumnPP).Row
DataColPP = Range(DataColumnPP).Column
DataRowCo = Range(DataColumnCO).Row
DataColCo = Range(DataColumnCO).Column
DataRowUnmatched = Range(DataColumnUnmatched).Row
DataColUnmatched = Range(DataColumnUnmatched).Column
LastDataMM = Sheets(SheetMM).Cells(Rows.Count, DataColMM).End(xlUp).Row
LastDataPP = Sheets(SheetPP).Cells(Rows.Count, DataColPP).End(xlUp).Row
LastDataCO = Sheets(SheetCO).Cells(Rows.Count, DataColCo).End(xlUp).Row
LastDataUnmathced = Sheets(SheetUnmatched).Cells(Rows.Count, DataColUnmatched).End(xlUp).Row
For counter = DataRowMM To LastDataRowMM
If WorksheetFunction.CountIf(LastDataPP, counter) = 0 Then
LastDataUnmathced.Offset(1) = counter
End If
Next
For counter = DataRowMM To LastDataRowMM
If WorksheetFunction.CountIf(LastDataCO, counter) = 0 Then
LastDataUnmathced.Offset(1) = counter
End If
Next
For counter = DataRowPP To LastDataRowPP
If WorksheetFunction.CountIf(LastDataCO, counter) = 0 Then
LastDataUnmathced.Offset(1) = counter
End If
Next
End Sub
Based on the information you've provided, you want to:
Check three tables across three sheets in the ActiveWorkbook
Check to see if the same number of constants exists in the table ranges
Highlight cells red where the values between the three sheets aren't the same
I've simplified the code in order to achieve these targets
Sub MatchValue()
Dim Range1 As Range, Range2 As Range, Range3 As Range
With ActiveWorkbook
With .Sheets("MM") 'First Sheet Name
Set Range1 = .Range("B6") 'Address of first row on First Sheet
Set Range1 = .Range(Range1, .Cells(.Rows.Count, Range1.Column).End(xlUp))
End With
With .Sheets("PP") 'Second Sheet Name
Set Range2 = .Range("B6") 'Address of first row on second Sheet
Set Range2 = .Range(Range2, .Cells(.Rows.Count, Range2.Column).End(xlUp))
End With
With .Sheets("CO") 'Third Sheet Name
Set Range3 = .Range("B6") 'Address of first row on third Sheet
Set Range3 = .Range(Range3, .Cells(.Rows.Count, Range3.Column).End(xlUp))
End With
End With
'Delete this part if you don't want to remove the existing fill (might be handy)
Range1.Interior.Pattern = xlNone
Range2.Interior.Pattern = xlNone
Range3.Interior.Pattern = xlNone
'Checks to see if the same number of constants exist within the test ranges
If Range1.SpecialCells(xlCellTypeConstants).Count <> _
Range2.SpecialCells(xlCellTypeConstants).Count Then
MsgBox "Range 1 and Range 2 constant count doesn't match", vbCritical, "Error Report"
ElseIf Range2.SpecialCells(xlCellTypeConstants).Count <> _
Range3.SpecialCells(xlCellTypeConstants).Count Then
MsgBox "Range 1 and Range 2 constant count doesn't match", vbCritical, "Error Report"
End If
Dim Temp1 As Variant, Temp2 As Variant, Temp3 As Variant, x As Long
'Checks to see if all the values entered are the same, if not, fills them red
Temp1 = Range1.Value
Temp2 = Range2.Value
Temp3 = Range3.Value
For x = 1 To UBound(Temp1, 1)
If Temp1(x, 1) <> Temp2(x, 1) Or _
Temp2(x, 1) <> Temp3(x, 1) Then
Range1.Cells(x, 1).Interior.Color = RGB(255, 0, 0)
Range2.Cells(x, 1).Interior.Color = RGB(255, 0, 0)
Range3.Cells(x, 1).Interior.Color = RGB(255, 0, 0)
End If
Next x
End Sub
I have a bubble sort that only works with the first element.
This is solved by reevaluating my array elements and placing them accordingly, which happens if I run the whole thing time and time again.
I'd like to add a recursive loop that's set to break when the sort is done.
I tried adding a function, but I'm not solid enough on my syntax to combine it with my sub. What is a basic recursion loop for this code? Function not expressly required, just something that will let me recall my sub.
Private Sub SortEverything_Click()
Dim everything() As Range
Dim check As Range
Dim count As Range
Dim sorting As Range
Dim holder As Range
Dim middleman As Range
Dim firstman As Range
Dim Temp1 As String
Dim Temp2 As String
Dim lr As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim q As Long
Dim everyrow As Long
Dim everycol As Long
Dim firstrow As Long
Dim firstcol As Long
y = 0
z = 0
q = 0
With ThisWorkbook.Sheets("Names and Vendors")
lr = .Cells(.Rows.count, "B").End(xlUp).Row
'Counts number of RMs to size the "everything" array
For z = 2 To lr
Set count = .Range("B" & z)
If IsEmpty(count) = False Then
count.Select
q = q + 1
End If
Next z
ReDim everything(q - 1) As Range 'Resizes array
'Loops all RM info into array by each distinct range
For x = 2 To lr
Set check = .Range("A" & x & ":H" & x)
'ensures subcomponents are added to range
If IsEmpty(.Range("B" & 1 + x)) = True Then
Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
check.Select
x = x + 1
Loop
End If
Set everything(y) = check
y = y + 1
check.Select
Next x
'This For has been commented out so that it doesn't run more than once
'For y = 0 To q - 1
'sorting allows us to copy/paste into a helper range line-by-line as the program loops
'firstman is the helper range. firstrow and firstcol return the dimensions of the everything(y) so that we can resize things
Set sorting = everything(0)
Set firstman = .Range("B20")
Set firstman = firstman.Resize(sorting.Rows.count, sorting.Columns.count)
firstman.Value = sorting.Value
firstrow = firstman.Rows.count
firstcol = firstman.Columns.count
'Returns the name of the RM listed to compare to the one below it
sorting.Offset(0, 1).Select
ActiveCell.Select
Temp1 = "" & ActiveCell.Value
For x = 1 To q - 1
'Checks whether a selected component has subcomponents and identifies its dimensions
sorting.Select
Set holder = everything(x)
holder.Offset(0, 1).Select
everyrow = Selection.Rows.count
everycol = Selection.Columns.count
'Returns the name of the material being compared to the referenced material in everything(y)
ActiveCell.Select
Temp2 = "" & ActiveCell.Value
If Temp2 > Temp1 Then 'If the RM we're on comes alphabetically after the name of the one we're checking against, then
If everyrow > 1 Then 'Handles if everything(x) has subcomponents
'Resize the other helper range to be the same as the range with subcomponents and paste the values into it
Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
Set middleman = middleman.Resize(everyrow, everycol)
middleman.Select
middleman.Value = holder.Value
'Resize the range we're pasting into in the master table so it can take the new range, then paste
Set sorting = sorting.Resize(everyrow, everycol)
sorting.Select
sorting.Value = holder.Value
'Resize the holder column to the same size as everything(y).
'Then paste everything(y) into the space BELOW the one we've just shifted upwards
Set holder = holder.Resize(firstrow, firstcol)
Set holder = holder.Offset(everyrow - 1, 0)
holder.Select
holder.Value = firstman.Value
Set sorting = sorting.Offset(everyrow, 0)
Else
Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
Set middleman = middleman.Resize(firstrow, firstcol)
middleman.Select
middleman.Value = holder.Value
Set sorting = sorting.Resize(everyrow, everycol)
sorting.Select
sorting.Value = holder.Value
Set holder = holder.Resize(firstrow, firstcol)
'Set firstman = firstman.Resize(everyrow, everycol)
holder.Select
holder = firstman.Value
Set sorting = sorting.Offset(1, 0)
End If
End If
Next x
'Next y
'This is where my inexperience shows. The recursion should go here, but I'm not sure how to do so.
'PopulateArray (everything)
End With
End Sub
Public Function PopulateArray(myArray()) As Variant
Dim myArray() As Range
Dim check As Range
Dim count As Range
Dim sorting As Range
Dim holder As Range
Dim middleman As Range
Dim firstman As Range
Dim Temp1 As String
Dim Temp2 As String
Dim lr As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim q As Long
y = 0
z = 0
q = 0
With ThisWorkbook.Sheets("Names and Vendors")
lr = .Cells(.Rows.count, "B").End(xlUp).Row
'Counts number of RMs to size the "myArray" array
For z = 2 To lr
Set count = .Range("B" & z)
If IsEmpty(count) = False Then
count.Select
q = q + 1
End If
Next z
ReDim myArray(q - 1) As Range 'Resizes array
'Loops all RM info into array by each distinct range
For x = 2 To lr
Set check = .Range("A" & x & ":H" & x)
'ensures subcomponents are added to range
If IsEmpty(.Range("B" & 1 + x)) = True Then
Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
check.Select
x = x + 1
Loop
End If
Set myArray(y) = check
y = y + 1
check.Select
Next x
End With
End Function
Found out what I needed to do. Put the whole thing under a Do loop and then added the following lines to it:
'checking to see if array is completely alphabetized
For Each cell In .Range("B2:B" & lr)
'Returns first check value
If IsEmpty(cell) = False Then
cell.Select
check1 = "" & cell.Value
x = cell.Row
.Range("A14").Value = check1
'Returns next check value
For z = x + 1 To lr
Set checking = .Range("B" & z)
If IsEmpty(checking) = False Then
checking.Select
check2 = "" & .Range("B" & z).Value
.Range("A15").Value = check2
Exit For
End If
Next z
Else
End If
If check2 > check1 Then
Exit For
End If
Next cell
'If the last two values are sorted, then the whole thing is sorted and we can stop the recursion
If check2 < check1 Or check1 = check2 Then
Exit Do
End If
I am running sub where it compares two cells (B and D/or string Received) from one sheet ("DATA") with two cells (C, H) from another sheet ("Incoming_report"), and if they match it transposes I, G cells from Incoming to Data.
It is done by combining two cells from Incoming_report sheet and writing new value in Z column for example "123456" from C and H to f.e. "123456Received" (there another 5 statuses (Received, Rejected, Sent...., but I need the ones only that was Received)
Then I am taking from Data Sheet B column for example 123456 and only Received (there might be another 5 statuses, but I only need the one that was received).
That makes all sence to me and works pretty good, but I have to work with more than 500k rows in each sheet. What happens - 500,000 times two cells are combined and searched in Z column in another sheet among another 500,000 for possible match, if nothing found then N/A, and then 2 combination, 3rd, 4th... till 500,000. I added the Display status bar and I see how slowly it goes (only 900 rows per minute, so for one minor mapping it would take more than 10 hours). Here is the sub itself, can anyone share ideas how to improve it to make it work faster? Thanks a million.
Sub incoming_fetch()
Application.ScreenUpdating = False
Dim incr As Long
Dim x As String
n = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
Z = Sheets("Incoming_report").Range("D" & Rows.Count).End(xlUp).Row
For i2 = 2 To Z
Sheets("Incoming_report").Range("Z" & i2).Value = Sheets("Incoming_report").Range("C" & i2).Value & Sheets("Incoming_report").Range("H" & i2).Value
Next i2
For i = 3 To n
Application.DisplayStatusBar = True
Application.StatusBar = i
x = Sheets("Data").Range("B" & i).Value & "Received"
If Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas) Is Nothing Then
Sheets("Data").Range("L" & i) = "N/A"
Sheets("Data").Range("M" & i) = "N/A"
Else
incr = Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas).Row
Sheets("DATA").Range("L" & i) = Sheets("Incoming_report").Range("I" & incr)
Sheets("DATA").Range("M" & i) = Sheets("Incoming_report").Range("G" & incr)
End If
Next i
End Sub
EDIT2: fixed source columns :
Sub incoming_fetch()
Dim i As Long, n As Long, z As Long, num As Long
Dim x As String
Dim shtIn As Worksheet, shtData As Worksheet
Dim dict As Object, arrC, arrH, arrG, arrI, v, arr, r1, r2
Dim t
Set dict = CreateObject("scripting.dictionary")
Set shtIn = Sheets("Incoming_report")
Set shtData = Sheets("Data")
n = shtData.Range("A" & Rows.Count).End(xlUp).Row
z = shtIn.Range("D" & Rows.Count).End(xlUp).Row
t = Timer
'get all values from Cols C, H, L, M
arrC = shtIn.Range(shtIn.Range("C2"), shtIn.Range("C" & z)).Value
arrH = shtIn.Range(shtIn.Range("H2"), shtIn.Range("H" & z)).Value
arrG = shtIn.Range(shtIn.Range("G2"), shtIn.Range("G" & z)).Value
arrI = shtIn.Range(shtIn.Range("I2"), shtIn.Range("I" & z)).Value
Debug.Print "Get Arrays: " & Timer - t
t = Timer
'create a lookup dictionary of all the ColC values
' (where ColH = "Received")
num = UBound(arrC, 1)
For i = 1 To num
v = arrC(i, 1)
If arrH(i, 1) = "Received" And Len(v) > 0 Then
dict(v) = Array(arrI(i, 1), arrG(i, 1))
End If
Next i
'free up some memory
Erase arrC: Erase arrH: Erase arrI: Erase arrG
Debug.Print "Filled dict: " & Timer - t
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo haveError
For i = 3 To n
If i Mod 500 = 0 Then Application.StatusBar = i
x = shtData.Range("B" & i).Value
If dict.exists(x) Then
arr = dict(x)
r1 = arr(0)
r2 = arr(1)
Else
r1 = "N/A": r2 = "N/A"
End If
With shtData
.Range("L" & i) = r1
.Range("M" & i) = r2
End With
Next i
Debug.Print "Done: " & Timer - t
haveError:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I am looking to concatenate cells in a column. the model begins with a model number without any . the options to that model begin with . I would like the marco to concatenate all the way until the beginning of the next model number (the next cell that does not begin with .) , then repeat process, I have provided a an example below. Any help would be greatly appreciated!
current State
abc
.bcr
.kjl
.plk
ghy
.ytr
.ihgew
.rth
.u
.lpn
trh
.pjkjh
.dsgyudd
.hg
.gfd
Future State
abc.bcr.kjl.plk
ghy.ytr.ihgew.rth.u.lp
trh.pjkjh.dsgyudd.hg.gfd
Try this:
Option Explicit
Sub ConditionalConcatenate()
'col A contain the texts and col B in corresponding row hold concatenated result
Dim strDone As String
Dim rngg As Range, lastcolA As Range, rngused As Range
Dim counted As Integer, i As Integer, j As Integer
Range("B:B").ClearContents
strDone = ""
Set rngg = ActiveSheet.Range("A:A")
Set lastcolA = rngg.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious)
Set rngused = Range("A1:A" & lastcolA.Row)
counted = rngused.Rows.Count
For i = 1 To counted
If Left(rngused(i), 1) <> "." Then
strDone = strDone & rngused(i)
For j = 1 To counted
If Left(rngused(i).Offset(j, 0), 1) = "." Then
strDone = strDone & rngused(i).Offset(j, 0)
ElseIf Left(rngused(i).Offset(j, 0), 1) <> "." Then
Range("B" & i).Value = strDone
strDone = ""
Exit For
End If
Next
End If
Next
Set rngg = Nothing
Set lastcolA = Nothing
Set rngused = Nothing
End Sub