I've written a very simple loop that goes through a table column and colors negative values red, positive values green and removes empty rows.
The problem occurs when rows are deleted. I update the value of the RowCount, and compensate i to check the same row again since a row was just deleted. If I have a column with 10 rows of which 2 are empty, they are deleted. I would expect the For i = 1 to RowCount to stop at 8, but it continues to 9 and produces an error because it then tries to delete the nonexistent 9th row.
What do I need to do so the loop stops at 8 instead of continuing (to I assume the initial value of the RowCount.
Sub ColourFilledCells()
Dim Table1 As ListObject
Set Table1 = ThisWorkbook.Worksheets(1).ListObjects(1)
Dim i As Lon, RowCount As Long
RowCount = Table1.ListRows.Count
For i = 1 To RowCount
If Not Table1.DataBodyRange(i, 1) = Empty Then
With Table1.DataBodyRange(i, 1)
If .Value < 0 Then
.Interior.Color = RGB(255, 0, 0)
ElseIf .Value > 0 Then
.Interior.Color = RGB(0, 255, 0)
Else
.ColorIndex = 0
End If
End With
ElseIf Table1.DataBodyRange(i, 1) = Empty Then
Table1.ListRows(i).Delete
RowCount = RowCount - 1
i = i - 1
End If
Next i
End Sub
To avoid issues with Delete affecting to For loop, count backwards.
Your code, refactored (Plus a few suggestions)
For i = RowCount to 1 Step -1
If Not isempty( Table1.DataBodyRange(i, 1)) Then
With Table1.DataBodyRange(i, 1)
If .Value < 0 Then
.Interior.Color = vbRed
ElseIf .Value > 0 Then
.Interior.Color = vbGreen
Else
.ColorIndex = xlColorIndexNone
End If
End With
Else
Table1.ListRows(i).Delete
End If
Next i
Try this code :
Sub ColourFilledCells()
Dim Table1 As ListObject
Dim uRng As Range
Set Table1 = ThisWorkbook.Worksheets(1).ListObjects(1)
Dim i As Long, RowCount As Long
RowCount = Table1.ListRows.Count
For i = 1 To RowCount
If Not Table1.DataBodyRange(i, 1) = Empty Then
With Table1.DataBodyRange(i, 1)
If .Value < 0 Then
.Interior.Color = RGB(255, 0, 0)
ElseIf .Value > 0 Then
.Interior.Color = RGB(0, 255, 0)
Else
.ColorIndex = 0
End If
End With
ElseIf Table1.DataBodyRange(i, 1) = Empty Then
If uRng Is Nothing Then
Set uRng = Table1.ListRows(i).Range
Else
Set uRng = Union(uRng, Table1.ListRows(i).Range)
End If
End If
Next i
If Not uRng Is Nothing Then uRng.Delete xlUp
End Sub
Related
I would like to select a cell in column C and check if the two cells above it are equal to 0. If they are equal to 0, I would like the ActiveCell to equal 1 Else I would like the ActiveCell to equal 0. I would then like to select the cell that is down 3 from the initial cell and repeat the process. I would like to do this 773 times. The issue I'm having is with the IF/AND section, it is always selecting 0 even when it should select a 1. Any idea what I did wrong. Working in an excel file that was converted from a CSV.
Range("C4").Select
For i = 1 To 773
If ActiveCell.Offset(-1, 0).Value = “0” And ActiveCell.Offset(-2, 0).Value = “0” Then
ActiveCell = "1" Else
ActiveCell = "0"
ActiveCell.Offset(3, 0).Select
Next i
It is best to avoid Activate and Select. Also, you can step the increment without having to add to the selection.
Sub test()
Dim sht As Workbook
Set sht = ActiveWorkbook 'or actual sheet name
For i = 4 To 773 Step 3
If sht.Cells(i - 1, 4).Value = 0 And sht.Cells(i - 2, 4).Value = 0 Then
sht.Cells(i, 4) = 1
Else
sht.Cells(i, 4) = 0
End If
Next i
End Sub
Testing a Range
The unexpected result (zeros) is due to the use of "0" which cannot be found.
Option Explicit
' Not recommended. Note how slow it is compared to the other solutions.
' The trick is in avoiding using "Select" and any 'flavor' of "Active".
' Runtime: 2100ms (over 2 seconds)
Sub testQuickFix()
Range("C4").Select
Dim i As Long
For i = 1 To 773
' This has to be one line: note the line separators ('_').
If ActiveCell.Offset(-1, 0).Value = 0 _
And ActiveCell.Offset(-2, 0).Value = 0 Then _
ActiveCell = 1 Else _
ActiveCell = 0
ActiveCell.Offset(3, 0).Select
Next i
End Sub
' Highly recommended, but maybe too advanced (You should learn about arrays).
' Note that this is only useful if the data are values, not formulas, because
' the whole range is overwritten.
' Runtime: 5ms
Sub testArray()
Dim rg As Range: Set rg = Range("C2:C2320")
Dim Data As Variant: Data = rg.Value
Dim i As Long
For i = 1 To UBound(Data, 1) Step 3
If Data(i, 1) = 0 And Data(i + 1, 1) = 0 Then
Data(i + 2, 1) = 1
Else
Data(i + 2, 1) = 0
End If
Next i
rg.Value = Data
End Sub
' Recommended.
' Runtime: 80ms
Sub testIfThenElseEndIf()
Dim rg As Range: Set rg = Range("C2:C4")
Dim i As Long
For i = 1 To 773
' This is considered more readable and is mostly used on SO.
If rg(1).Value = 0 And rg(2).Value = 0 Then
rg(3).Value = 1
Else
rg(3).Value = 0
End If
' It is short for:
' If rg.Cells(1).Value = 0 And rg.Cells(2).Value = 0 Then
' rg.Cells(3).Value = 1
' Else
' rg.Cells(3).Value = 0
' End If
' which I actually prefer.
Set rg = rg.Offset(3)
Next i
End Sub
' Not recommended.
' Runtime: 80ms
Sub testIfThenElse()
Dim rg As Range: Set rg = Range("C2:C4")
Dim i As Long
For i = 1 To 773
' This is valid, but rarely seen on SO.
' Note that this is one line.
'If rg(1).Value = 0 And rg(2).Value = 0 Then rg(3).Value = 1 Else rg(3).Value = 0
' Note that this is also one line, but uses a line separator.
If rg(1).Value = 0 And rg(2).Value = 0 Then rg(3).Value = 1 _
Else rg(3).Value = 0
Set rg = rg.Offset(3)
Next i
End Sub
' (A little less) recommended.
' Runtime: 80ms
Sub testIIF()
Dim rg As Range: Set rg = Range("C2:C4")
Dim i As Long
For i = 1 To 773
' This is another way.
rg(3).Value = IIf(rg(1).Value = 0 And rg(2).Value = 0, 1, 0)
Set rg = rg.Offset(3)
Next i
End Sub
I believe this would work for your instance.
Public Sub ReadingCells()
With Sheet1
Range("C4").Select
For i = 1 To 773
If ActiveCell.Offset(-1, 0).Value + ActiveCell.Offset(-2, 0).Value = "0" Then
ActiveCell.Value = "1"
Else
ActiveCell.Value = "0"
End If
ActiveCell.Offset(3, 0).Select
Next i
End With
End Sub
I have researched several codes but it's either for blanks only or zeroes only, and I need a code for both blanks and zeroes.
I have 3 columns to note if this should be deleted or not
I need to delete the rows with complete details(ID, and Address)(the Name is the basis for the details), since I need the rows with incomplete details(ID or Address as zeroes or blanks) to retain.
ID Name Address
1 A 123 ABC
2 B 0
C 345 CDE
D
5 E 567 EFG
0 F 678 FGH
7 G 789 GHI
0 H 0
My first try was this code, it works for the conditions, but if I have succeeding blanks, it skips the next row, since that row goes up
lrow = 1000
For x = 2 To lrow
If Cells(x,2)<>"" Then
If Cells(x,1) <> "" Or Cells(x,1) <> "0" Or Cells(x,3) <> "" Or Cells(x,3) <> "0" Then
Cells(x,11).EntireRow.Delete
End If
End If
Next x
So I tried this code, where I start from bottom to up.
lrow = 1000
For x = lrow To 2 Step -1
If Cells(x,2)<>"" Then
If Cells(x,1) <> "" Or Cells(x,1) <> "0" Or Cells(x,3) <> "" Or Cells(x,3) <> "0" Then
Cells(x,11).EntireRow.Delete
End If
End If
Next x
But that code ignores the conditions except the first one, then also deletes the other row s with incomplete details.
I'm kind of stuck with this, since I also have to create another one where I do the reverse, keep the complete details, and delete the incomplete ones.
Replace the for loop with a do while loop. If the row is deleted, decrement the total number of rows, otherwise increment the row counter.
lastRow = 1000
row = 2
Do While row <= lastRow
If Cells(row,1)<>"" Then
If Cells(row,1) <> "" Or Cells(row,1) <> "0" Or Cells(row,3) <> "" Or Cells(row,3) <> "0" Then
Rows(row).Delete
lastRow = lastRow - 1
else
row = row + 1
End If
End If
Loop
Delete Rows with Conditions
Loop Backward
Sub testSimple()
Const lrow As Long = 1000
Dim x As Long
For x = lrow To 2 Step -1
If Len(Cells(x, 1)) > 0 And Cells(x, 1) <> 0 Then
If Len(Cells(x, 3)) > 0 And Cells(x, 3) <> 0 Then
Rows(x).Delete
End If
End If
Next x
End Sub
EDIT:
The star of the show is the If statement which should ideally (most efficiently) actually be:
If Len(Cells(x, 1)) > 0 Then
If Cells(x, 1) <> 0 Then
If Len(Cells(x, 3)) > 0
If Cells(x, 3) <> 0 Then
Rows(x).Delete
End If
End If
End If
End If
All four conditions have to be true. If one isn't, the others are not evaluated.
On the other hand you can write it like this
If Len(Cells(x, 1)) > 0 And Cells(x, 1) <> 0 _
And Len(Cells(x, 3)) > 0 And Cells(x, 3) <> 0 Then
Rows(x).Delete
End If
... the difference being that in the latter (less efficient) all four conditions are evaluated, even if the first is already false.
For the opposite you could use the same conditions and do the following (note the Else):
If Len(Cells(x, 1)) > 0 And Cells(x, 1) <> 0 _
And Len(Cells(x, 3)) > 0 And Cells(x, 3) <> 0 Then
' Do nothing
Else
Rows(x).Delete
End If
Let's rewrite the opposite using Or:
If Len(Cells(x, 1)) = 0 Or Cells(x, 1) = 0 _
Or Len(Cells(x, 3)) = 0 Or Cells(x, 3) = 0 Then
Rows(x).Delete
End If
So similar to the 'opposite idea' you could write the initial statement like this (note the Else):
If Len(Cells(x, 1)) = 0 Or Cells(x, 1) = 0 _
Or Len(Cells(x, 3)) = 0 Or Cells(x, 3) = 0 Then
' Do nothing
Else
Rows(x).Delete
End If
The Finale (for the opposite)
Using the Select Case statement you can write the opposite like this:
Sub testSimple()
Const lrow As Long = 1000
Dim x As Long
For x = lrow To 2 Step -1
Select Case True
Case Len(Cells(x, 1)) = 0, Cells(x, 1) = 0, _
Len(Cells(x, 3)) = 0, Cells(x, 3) = 0
Rows(x).Delete
End Select
Next x
End Sub
... where the commas 'mean Or', so if any of the expressions are true, the rows will be deleted.
OLD (Continuation):
Delete in One Go Using the CombinedRange Function
Sub test()
Const lrow As Long = 1000
Dim drg As Range
Dim x As Long
For x = 2 To lrow
If Len(Cells(x, 1)) > 0 And Cells(x, 1) <> 0 Then
If Len(Cells(x, 3)) > 0 And Cells(x, 3) <> 0 Then
Set drg = CombinedRange(drg, Rows(x))
End If
End If
Next x
If Not drg Is Nothing Then
drg.Delete
End If
End Sub
Delete in One Go Using the CombinedRange Function Improved
Sub testImp()
Const Cols As String = "A:C"
Const fRow As Long = 2
Dim rg As Range
With Columns(Cols).Rows(fRow)
Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If rg Is Nothing Then Exit Sub
Set rg = .Resize(rg.Row - .Row + 1)
End With
Dim drg As Range
Dim rrg As Range
For Each rrg In rg.Rows
If Len(rrg.Cells(1)) > 0 And rrg.Cells(1) <> 0 Then
If Len(rrg.Cells(3)) > 0 And rrg.Cells(3) <> 0 Then
Set drg = CombinedRange(drg, rrg.EntireRow)
End If
End If
Next rrg
If Not drg Is Nothing Then
drg.Delete
End If
End Sub
The CombinedRange Function
Function CombinedRange( _
ByVal BuildRange As Range, _
ByVal AddRange As Range) _
As Range
If BuildRange Is Nothing Then
Set CombinedRange = AddRange
Else
Set CombinedRange = Union(BuildRange, AddRange)
End If
End Function
I need to merge the cells one above the months.
Cells Should be merged from 01 to 12 showing year in cell.
Look for the picture for more clarification.
I have below code, but which show months after run in cell row1.
My idea is to convert above cells to years through vba and apply merge same year at the end.
which is shown in desired output.
Note.
ROW 4 and 5 are just my thinking, which will help year to merge.
Dim a(), i As Long, j As Long, m As Long, x As Range
With Range("b1:qaz1")
.MergeCells = False
.ClearContents
a() = .Offset(1).Value
m = Month(a(1, 1))
j = UBound(a, 2)
Set x = .Cells(1)
For i = 2 To j
If m <> Month(a(1, i)) Or i = j Then
With Range(x, .Cells(i - IIf(i = j, 0, 1)))
.MergeCells = True
.HorizontalAlignment = xlCenter
End With
x.Value = Format(DateSerial(2000, m, 1), "MMMM")
m = Month(a(1, i))
Set x = .Cells(i)
End If
Next
End With
End Sub
After running new program output look like
Since you have true dates in your caption row the month and year can be extracted from there. However, the code below converts dates that might have been created using formulas to hard dates before processing them.
Sub MergeCaptionsByYear()
' 031
Const CapsRow As Long = 1 ' change to suit
Const StartClm As Long = 2 ' change to suit
Dim Rng As Range ' working range
Dim Tmp As Variant ' current cell's value
Dim Cl As Long ' last used column
Dim Cstart As Long ' first column in Rng
Dim C As Long ' working column
Dim Yr As Integer ' year
Cl = Cells(CapsRow, Columns.Count).End(xlToLeft).Column
Range(Cells(CapsRow, StartClm), Cells(CapsRow, Cl)).Copy
Cells(CapsRow, StartClm).PasteSpecial xlValues
Application.CutCopyMode = False
C = StartClm - 1
Application.DisplayAlerts = False
Do
Tmp = Cells(CapsRow, C + 1).Value
If Not IsDate(Tmp) And (C <> Cl) Then
MsgBox "Cell " & Cells(CapsRow, C + 1).Address(0, 0) & _
" doesn't contain a date." & vbCr & _
"This macro will be terminated.", _
vbInformation, "Invalid cell content"
Exit Do
End If
If (Yr <> Year(CDate(Tmp))) Or (C = Cl) Then
If Yr Then
Set Rng = Range(Cells(CapsRow, Cstart), _
Cells(CapsRow, C))
With Rng
.Merge
.HorizontalAlignment = xlCenter
.NumberFormat = "yyyy"
End With
SetBorder Rng, xlEdgeLeft
SetBorder Rng, xlEdgeRight
End If
If C > (Cl - 1) Then Exit Do
Cstart = C + 1
Yr = Year(Tmp)
End If
C = C + 1
Loop
Application.DisplayAlerts = True
End Sub
Private Sub SetBorder(Rng As Range, _
Bord As XlBordersIndex)
' 031
With Rng.Borders(Bord)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium ' xlThin
End With
End Sub
Assuming the months range is "B5:AH5"
Sub test()
Dim monthsRng As Range
Set monthsRng = Range("B5:AH5")
monthsRng.Cells(1, 1).Offset(-1, 0).Select
For j = 1 To Int((monthsRng.Cells.Count / 12) + 2)
If ActiveCell.Offset(1, 0) <> 0 Then
For i = 1 To 12
ActiveCell.Value = Year(ActiveCell.Offset(1, 0))
If Year(ActiveCell.Offset(1, i)) = ActiveCell Then
Selection.Resize(1, i + 1).Select
Else
Exit For
End If
Next
With Selection
.HorizontalAlignment = xlCenter
.MergeCells = True
End With
Selection.Offset(0, 1).Select
Else
Exit For
End If
Next
End Sub
Replacing the inner for loop with below code will work irrespective of whether the dates in the Range("B5:AH5") in above procedure are formatted as dates or not.
For i = 1 To 12
ActiveCell.Value = Right(Format(ActiveCell.Offset(1, 0), "DD.MM.YYYY"), 4)
If Right(Format(ActiveCell.Offset(1, i), "DD.MM.YYYY"), 4) = Format(ActiveCell, Text) Then
Selection.Resize(1, i + 1).Select
Else
Exit For
End If
Next
However, in any case you need to format the output in excel as number (without 1000 separator and decimal places) and not date.
I am very new with VBA in Excel. What I want to accomplish is this. When a user enters a length of say 5, then 5 columns must be outlined red. Then also when a user enters a width of say 6, then 6 rows must be outlined red. Example:
I have this code thus far:
On worksheet change:
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Address = "$A$2") Then
Call Draw2DTankl
ElseIf (Target.Address = "$B$2") Then
Call Draw2DTankw
End If
End Sub
Draw2DTankl:
Sub Draw2DTankl()
On Error Resume Next
Cells(2, 4).Value = ""
Dim x As Range
Set x = Worksheets("Sheet1").Cells
x.Borders.LineStyle = xNone
Range("A1") = "Length"
Dim Length As Integer
Length = CInt(Cells(2, 1).Value)
If (Length > 30) Then
MsgBox "A length of a maximum 30 is allowed"
Exit Sub
End If
If (Length < 0) Then
MsgBox "Invalid length value entered"
Exit Sub
End If
Dim Rws As Long, Rng As Range, r As Range
If (Length > 0) Then
Rws = 20
Set Rng = Range(Cells(20, "H"), Cells(Rws, 8 + Length - 1))
For Each r In Rng.Cells
With r.Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 3
End With
Next r
End If
If (Err.Number <> 0) Then
MsgBox Err.Description
End If
End Sub
Draw2DTankw:
Sub Draw2DTankw()
On Error Resume Next
Cells(2, 4).Value = ""
Dim x As Range
Set x = Worksheets("Sheet1").Cells
x.Borders.LineStyle = xNone
Range("B1") = "Width"
Dim Width As Integer
Width = CInt(Cells(2, 2).Value)
If (Width > 30) Then
MsgBox "A width of a maximum 30 is allowed"
Exit Sub
End If
If (Width < 0) Then
MsgBox "Invalid Width value entered"
Exit Sub
End If
Dim Col As Long, Rng As Range, r As Range
If (Width > 0) Then
Col = 21
Set Rng = Range(Cells(21, "H"), Cells(Col, 8 + Length - 1))
For Each r In Rng.Cells
With r.Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 3
End With
Next r
End If
If (Err.Number <> 0) Then
MsgBox Err.Description
End If
End Sub
Please help me. My code doesn't work. The length works, but that brakes when I change the width.
Entering my length draws:
Which is correct. But then if I enter the width of 6 this happens: (my length also dissapears)
I apologize for this long post!
It looks like in the Draw2DTankw you have Width declared above but in the rng you are using length
Dim Width As Integer Width = CInt(Cells(2, 2).Value)
Set Rng = Range(Cells(21, "H"), Cells(Col, 8 + Length - 1))
I've modified your code to draw both height and width by extending the range to include the width. This worked with I test it.
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Address = "$A$2") Or (Target.Address = "$B$2") Then
DrawTable
End If
End Sub
Sub DrawTable()
On Error Resume Next
Cells(2, 4).Value = ""
Dim x As Range
Set x = ActiveSheet.Cells
x.Borders.LineStyle = xNone
Range("A1") = "Length"
Dim Length As Integer
Length = CInt(Cells(2, 1).Value)
'Combined Width sections
Dim Width As Integer
Width = CInt(Cells(2, 2).Value)
If (Length > 30) Then
MsgBox "A length of a maximum 30 is allowed"
Exit Sub
ElseIf (Width > 30) Then
MsgBox "A width of a maximum 30 is allowed"
Exit Sub
ElseIf (Length < 0) Then
MsgBox "Invalid length value entered"
Exit Sub
ElseIf (Width < 0) Then
MsgBox "Invalid Width value entered"
Exit Sub
End If
Dim Rws As Long, Rng As Range, r As Range
If (Length > 0) Then
Rws = 20
'Added width to cells(rws)
Set Rng = Range(Cells(20, "H"), Cells(Rws + Width - 1, 8 + Length - 1))
For Each r In Rng.Cells
With r.Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 3
End With
Next r
End If
If (Err.Number <> 0) Then
MsgBox Err.Description
End If
End Sub
I am looking for a similar formula, as here:
How to copy data from sheet1 to sheet2 with a condition in Excel
I am using:
=IF(EXACT(Sheet1!B4,Sheet2!A7),Sheet1!A4)
only I want to add the condition that if column B of sheet1 doesn't have the value that I am looking for it will look at the next row in column B. If this matches then the value of that row in column A would be the value copied.
Thanks
It seems clear that no one is going to offer you a formula solution. Certainly I would not know how to solve your problem with formulae.
You have not defined the format of either your source or your destination sheet. However, I had some code which I was able to hack around to match possible formats.
On the left of the image below is my source sheet. Note that column C contains a date which I have formatted as "ddd dd" because I find that a convenient format for this type of list. On the right is a print image of the output. The column widths, borders and cell merging are as set by the macro.
The sequence of station names is set by an array within the macro. I have three stations but this is arbitrary. The start date, start time, end time and end date in the output table are set by the earliest and latest values in the source table.
The original validation in the macro does not match your requirement so I have deleted it. You will need to add your own.
The macro does not notice that Angela has two stations at 12:00 on Tuesday. It does notice that source rows 13 and 18 overlap previous entries and reports these errors.
The code below includes comments explaining what it is doing but not why or how. I hope this gives you some ideas. Come back with questions if necessary.
Option Explicit
Type typStationBooking
NamePerson As String
NameStation As String
BookDate As Date
BookTimeStart As Long ' Time in minutes 540 = 9:00
BookTimeEnd As Long ' Time in minutes 900 = 15:00
End Type
Sub ListByNameToListByStation()
Dim ColDataCrnt As Long
Dim DateCrnt As Date
Dim DateLatest As Date
Dim DateEarliest As Date
Dim Found As Boolean
Dim InxBookCrnt As Long
Dim InxBookMax As Long
Dim InxStatCrnt As Long
Dim NumRowsPerDay As Long
Dim NumStations As Long
Dim NumTimeSlots As Long
Dim Occupied As Boolean
Dim RowDataCrnt As Long
Dim RowDataDayFirst As Long
Dim RowDataLast As Long
Dim RowDataTimeSlot As Long
Dim StationBooking() As typStationBooking
Dim StationName() As Variant
Dim SheetDest As String
Dim SheetSrc As String
Dim TimeCrnt As Long
Dim TimeEarliest As Long
Dim TimeLatest As Long
Dim TimeInterval As Long
' Names of stations in desired column sequence. Names must match
' those used in worksheet Source. LBound = 0
StationName = Array("Station2", "Station3", "Station1")
SheetDest = "Dest" ' ) Change to your
SheetSrc = "Source" ' ) sheet names
DateEarliest = -1
DateLatest = -1
TimeInterval = 30 ' ) Values in minutes. Change as necessary
TimeEarliest = -1
TimeLatest = -1
With Sheets(SheetSrc)
' First Last used row
RowDataLast = .Cells(Rows.Count, "A").End(xlUp).Row
' Reserve space for rows 2 to RowLast
ReDim StationBooking(1 To RowDataLast - 1)
InxBookMax = 0 ' No current entries
' Load data from Sheet1 table into array
For RowDataCrnt = 2 To RowDataLast
' ### The source data should be checked:
' * Person name non-blank
' * Station name matches value in StationName()
' * Day is date in range DateFirst to DateLast
' * Start and End times are times in range TimeFirst to
' TimeLast+TimeInteval with Start time before End time
' and both are of the form TimeStart + N*TimeInterval
' where is a positive integer
InxBookMax = InxBookMax + 1
StationBooking(InxBookMax).NamePerson = .Cells(RowDataCrnt, 1).Value
StationBooking(InxBookMax).NameStation = .Cells(RowDataCrnt, 2).Value
StationBooking(InxBookMax).BookDate = .Cells(RowDataCrnt, 3).Value
StationBooking(InxBookMax).BookTimeStart = _
Hour(.Cells(RowDataCrnt, 4).Value) * 60 + _
Minute(.Cells(RowDataCrnt, 4).Value)
StationBooking(InxBookMax).BookTimeEnd = _
Hour(.Cells(RowDataCrnt, 5).Value) * 60 + _
Minute(.Cells(RowDataCrnt, 5).Value)
If DateEarliest = -1 Then
DateEarliest = StationBooking(InxBookMax).BookDate
DateLatest = StationBooking(InxBookMax).BookDate
Else
If DateEarliest > StationBooking(InxBookMax).BookDate Then
DateEarliest = StationBooking(InxBookMax).BookDate
End If
If DateLatest < StationBooking(InxBookMax).BookDate Then
DateLatest = StationBooking(InxBookMax).BookDate
End If
End If
If TimeEarliest = -1 Then
TimeEarliest = StationBooking(InxBookMax).BookTimeStart
TimeLatest = StationBooking(InxBookMax).BookTimeEnd
Else
If TimeEarliest > StationBooking(InxBookMax).BookTimeStart Then
TimeEarliest = StationBooking(InxBookMax).BookTimeStart
End If
If TimeLatest < StationBooking(InxBookMax).BookTimeEnd Then
TimeLatest = StationBooking(InxBookMax).BookTimeEnd
End If
End If
Next
End With
With Sheets(SheetDest)
' Lay out destination sheet
' Format per day
' Row 1 : Date
' Row 2 : Station names
' Row 3+: One row per time interval from TimeEarliest to
' TimeLatest + TimeInteval
' Row N : Blank row
' Col 1 : Time
' Col 2+: Station name
' Delete current contents
.Cells.EntireRow.Delete
NumRowsPerDay = (TimeLatest - TimeEarliest) / TimeInterval + 3
NumStations = UBound(StationName) + 1
' Set column widths
.Columns(1).ColumnWidth = 6
For ColDataCrnt = 2 To NumStations + 1
.Columns(ColDataCrnt).ColumnWidth = 14
Next
RowDataCrnt = 1
DateCrnt = DateEarliest
Do While DateCrnt <= DateLatest
RowDataDayFirst = RowDataCrnt
.Range(.Cells(RowDataCrnt, 1), .Cells(RowDataCrnt, 1 + NumStations)).Merge
With .Cells(RowDataCrnt, 1)
.HorizontalAlignment = xlCenter
.NumberFormat = "dddd d mmmm"
.Value = DateCrnt
End With
RowDataCrnt = RowDataCrnt + 1
InxStatCrnt = 0
For ColDataCrnt = 2 To NumStations + 1
.Cells(RowDataCrnt, ColDataCrnt).Value = StationName(InxStatCrnt)
InxStatCrnt = InxStatCrnt + 1
Next
RowDataCrnt = RowDataCrnt + 1
TimeCrnt = TimeEarliest
Do While TimeCrnt < TimeLatest
With .Cells(RowDataCrnt, 1)
.NumberFormat = "hh:mm"
.Value = DateCrnt + TimeSerial(TimeCrnt \ 60, TimeCrnt Mod 60, 0)
End With
RowDataCrnt = RowDataCrnt + 1
TimeCrnt = TimeCrnt + TimeInterval
Loop
With .Range(.Cells(RowDataDayFirst, 1), _
.Cells(RowDataCrnt - 1, NumStations + 1))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
End With
RowDataCrnt = RowDataCrnt + 1
DateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), Day(DateCrnt) + 1)
Loop
' Now place each entry in StationBooking in the appropriate cell(s)
For InxBookCrnt = 1 To InxBookMax
'Debug.Assert InxBookCrnt <> 17
DateCrnt = StationBooking(InxBookCrnt).BookDate
RowDataDayFirst = (DateCrnt - DateEarliest) * NumRowsPerDay + 1
TimeCrnt = StationBooking(InxBookCrnt).BookTimeStart
RowDataTimeSlot = RowDataDayFirst + 2 + _
(TimeCrnt - TimeEarliest) / TimeInterval
NumTimeSlots = (StationBooking(InxBookCrnt).BookTimeEnd - TimeCrnt) _
/ TimeInterval
Found = False
For InxStatCrnt = 0 To UBound(StationName)
If StationBooking(InxBookCrnt).NameStation = _
StationName(InxStatCrnt) Then
Found = True
Exit For
End If
Next
If Not Found Then
MsgBox ("Row " & InxBookCrnt + 1 & " of worksheet " & SheetSrc & _
"contains an unknown station name")
Else
ColDataCrnt = InxStatCrnt + 2
' Check space for this entry is not already occupied
Occupied = False
For RowDataCrnt = RowDataTimeSlot To RowDataTimeSlot + NumTimeSlots - 1
If .Cells(RowDataCrnt, ColDataCrnt) <> "" Then
Occupied = True
Exit For
End If
Next
If Not Occupied Then
If Range(.Cells(RowDataTimeSlot, ColDataCrnt), _
.Cells(RowDataTimeSlot + NumTimeSlots - 1, _
ColDataCrnt)).MergeCells Then
Occupied = True
End If
End If
If Occupied Then
MsgBox ("Row " & InxBookCrnt + 1 & " of worksheet " & SheetSrc & _
" overlaps a previous entry")
Else
' Entire slot is free
.Cells(RowDataTimeSlot, ColDataCrnt).Value = _
StationBooking(InxBookCrnt).NamePerson
If NumTimeSlots > 1 Then
With .Range(.Cells(RowDataTimeSlot, ColDataCrnt), _
.Cells(RowDataTimeSlot + NumTimeSlots - 1, ColDataCrnt))
.Merge
.WrapText = True
.VerticalAlignment = xlCenter
End With
End If
End If
End If
Next
End With
End Sub
The below sample could help you to copy values(row wise) from one sheet to another sheet based on matching column in From Sheet.
Sub TodaysActions()
Dim listSheetRange As Range
'Sheet to copy data From
Dim listSheet As Worksheet
'Sheet to copy data To
Dim actionSheet As Worksheet
Set listSheetRange = Worksheets("List").UsedRange
Set listSheet = Worksheets("List")
Set actionSheet = Worksheets("Action")
'Clear the To Sheet
actionSheet.UsedRange.Clear
'Row 1 of From Sheet contains the data to match
'Copy Header Row i.e Row 2 of From Sheet
listSheet.Rows(2).Copy Destination:=actionSheet.Rows(1)
currentActionRow = 2
For i = 3 To listSheetRange.Rows.Count
'Comparision Condition
If InStr(listSheetRange.Cells(i, 1), listSheetRange.Cells(1, 3)) Then
listSheet.Rows(i).Copy Destination:=actionSheet.Rows(currentActionRow)
currentActionRow = currentActionRow + 1
End If
Next i
'hide any unwanted columns
actionSheet.Columns(1).Hidden = 1
actionSheet.Activate
End Sub