VBA- clearing the contents of previously filled cells - excel

I have 2 column table with columns as bunker index and bunker name.. i have to index the bunker using VBA and then generate another table with columns as the Bunker names and 'first column as the date...
On changing the number of bunkers( like from 10 to 8).. the color of the cells(last 2 columns previosly filled) in second table remains the same (blue), which i require as default (white)
I have used many variables from my workbook. Any suggestion in this regard. As to how should the formatting be done?
This is the Code :
Sub Bunker_index_Click()
Sheet3.Range(Sheet3.Cells(4, 6), Sheet3.Cells(500, 100)).ClearContents
Dim N As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim LocalIYM As Date
LocalIYM = ThisWorkbook.IYM
N = Application.CountA(Range("B:B")) - 1
ThisWorkbook.NumBunker = N
MsgBox (N)
Cells(5, 1).Value = "Bunker Index"
For i = 1 To 100
If i <= N Then
Cells(5 + i, 1).Value = i
Cells(5 + i, 1).Interior.Color = RGB(253, 233, 217)
Cells(5 + i, 2).Interior.Color = RGB(219, 238, 243)
Else
Cells(5 + i, 1).ClearContents
Cells(5 + i, 2).ClearContents
End If
Next i
Range("F5").Value = "Time (LOCKED)"
Range("F5").Interior.Color = RGB(253, 233, 217)
For i = 1 To 100
If i <= N Then
Cells(5, 6 + i).Value = Cells(5 + i, 2)
Cells(5, 6 + i).Interior.Color = RGB(253, 233, 217)
Else
Cells(5, 6 + i).ClearContents ' unable to bring back th original
' color of the cells
End If
Next i
For k = 1 To 12 * 1
If k <= ThisWorkbook.N Then
Cells(k + 5, 6).Value = LocalIYM
LocalIYM = DateAdd("m", 1, LocalIYM)
Cells(5 + k, 6).Interior.Color = RGB(253, 233, 217) ' problem handling borders
' Range("B2").Borders(xlEdgeLeft).LineStyle = XlLineStyle.xlDashDot
' 1edgeleft).LineStyle = x1linestyle.x1countinous
For j = 1 To N
Cells(5 + k, 6 + j).Interior.Color = RGB(219, 238, 243)
Next j
Else
Sheet2.Cells(i + 4, 6).Clear
End If
Next k
End Sub


Instead of .clear or .clearcontents Try:
.Interior.Pattern = xlNone

Related

Compare two words and return the number of letter differences

The macro is written to return the number of letter differences (insertions, replacements, or deletions) of two words (case sensitive).
It is suppose to format and output in phrases
1-2 Letters off,
1-2 Letters off, Same Starting Letter,
3-4 Letters off,
3-4 Letters off, Same Starting Letter and
5 or more letters off, CHECK
It is only outputting
1-2 Letters off, Same Starting Letter,
3-4 Letters off, Same Starting Letter and
5 or more Letters off, CHECK
I would like the formatting to stay the same for now.
Sub Test_HW_Formatter()
'declare the variables
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim testNames As Integer
Dim responses As Integer
Dim printRow As Integer
Dim name As String
Dim count As Integer
Dim coding As String
Dim statLetter As Boolean
Dim tempCount As Integer
Dim tempResp As String
'the queues for the entries, the respective counts, and respective codes
Dim words As Object
Set words = CreateObject("System.Collections.Queue")
Dim counts As Object
Set counts = CreateObject("System.Collections.Queue")
Dim codes As Object
Set codes = CreateObject("System.Collections.Queue")
'set the variables
printRow = 3
testNames = Selection.Columns.count
responses = Selection.Rows.count - 1
Cells(4, 3).Value = Selection(4)
startLetter = True
'make the header
Cells(1, 1).Value = "Name"
Cells(1, 2).Value = "Response"
Cells(1, 3).Value = "Count"
Cells(1, 4).Value = "Code"
Cells(1, 5).Value = "Agency close matches"
Cells(1, 6).Value = "N=" + Trim(Str(responses))
Cells(1, 6).Interior.Color = RGB(255, 255, 204)
Cells(1, 6).HorizontalAlignment = xlCenter
For i = 1 To 5
Cells(1, i).Interior.Color = RGB(1, 139, 175)
Cells(1, i).Font.Color = RGB(255, 255, 255)
Cells(1, i).HorizontalAlignment = xlCenter
Next i
'get the information and put it in the queues
For i = 0 To (testNames - 1)
name = Selection(i + 1).Value
For j = 1 To responses
count = 1
If Not Selection(j * testNames + i + 1) = "" Then
For k = 1 To (responses - j)
If Not Selection((j + k) * testNames + i + 1).Value = "" Then
If Trim(UCase(Selection(j * testNames + i + 1).Value)) = Trim(UCase(Selection((j + k) * testNames + i + 1).Value)) Then
count = count + 1
Selection((j + k) * testNames + i + 1).Value = ""
End If
End If
Next k
'get the coding
coding = ""
ld = Levenshtein(name, Trim(UCase(Selection(j * testNames + i + 1))))
If Mid(testName, 1, 1) = Mid(sample, 1, 1) Then
startLetter = True
Else
startLetter = False
End If 'if for starting letter
Select Case ld
Case 0
coding = "Exact Match"
Case 1
If startLetter = True Then
coding = "1-2 Letters off, Same Starting Letter"
Else
coding = "1-2 Letters off"
End If
Case 2
If startLetter = True Then
coding = "1-2 Letters off, Same Starting Letter"
Else
coding = "1-2 Letters off"
End If
Case 3
If startLetter = True Then
coding = "3-4 Letters off, Same Starting Letter"
Else
coding = "3-4 Letters off"
End If
Case 4
If startLetter = True Then
coding = "3-4 Letters off, Same Starting Letter"
Else
coding = "3-4 Letters off"
End If
Case Else
coding = "5 or more Letters off, CHECK"
End Select
'enqueue the values
tempResp = UCase(Mid(Selection(j * testNames + i + 1).Value, 1, 1)) + LCase(Mid(Selection(j * testNames + i + 1).Value, 2, Len(Selection(j * testNames + i + 1).Value)))
words.enqueue (tempResp)
counts.enqueue (count)
codes.enqueue (coding)
End If 'if the cell is not blank
Next j
'print the queues from the ith column
'start the section header
Cells(printRow, 1).Value = name
Cells(printRow, 1).Font.Color = RGB(255, 255, 255)
For k = 1 To 5
Cells(printRow, k).Interior.Color = RGB(1, 139, 175)
Cells(printRow, k).HorizontalAlignment = xlCenter
Next k
tempCount = counts.count
Cells(150, 20 + i).Value = tempCount
For k = 1 To tempCount
Cells(printRow + k, 2).Value = words.dequeue
Cells(printRow + k, 3).Value = counts.dequeue
Cells(printRow + k, 4).Value = codes.dequeue
If Cells(printRow + k, 4).Value = "Exact Match" Then
Cells(printRow + k, 4).Interior.Color = RGB(236, 239, 218)
End If
Next k
printRow = printRow + tempCount + 2
Next i
End Sub

Edited to add counting replicates of the same name, and skip empty values:
Sub Test_HW_Formatter()
Dim arr, numReps As Long, ws As Worksheet, col As Long, c As Range
Dim nm As String, rep As Long, cmp As String
Dim i As Long, dict As Object, tmp
arr = Selection.Value 'inputs
numReps = UBound(arr, 1) - 1 'reps per column
Set ws = Selection.Parent 'sheet with selection
With ws.Range("A1:E1")
.Value = Array("Name", "Response", "Count", "Code", "Agency Close match")
doHeaders .Cells
End With
ws.Range("F1").Value = "N=" & numReps
Set c = ws.Range("A3") 'start of output sections
For col = 1 To UBound(arr, 2) 'loop columns of selection
nm = arr(1, col)
c.Value = nm
doHeaders c.Resize(1, 5) 'format headers
i = 0
Set dict = CreateObject("scripting.dictionary")
For rep = 1 To numReps 'loop values to compare
cmp = arr(rep + 1, col)
If Len(cmp) > 0 Then
If Not dict.exists(cmp) Then
i = i + 1
dict.Add cmp, i
c.Offset(i, 1).Value = cmp
c.Offset(i, 2) = 1
c.Offset(i, 3).Value = MatchCoding(nm, cmp) 'now in separate function
Else
'increment count for existing line
c.Offset(dict(cmp), 2).Value = c.Offset(dict(cmp), 2).Value + 1
End If
End If 'not zero-length
Next rep
Set c = c.Offset(i + 2, 0) 'next set
Next col
End Sub
'return a string summarizing how closeley two terms match
Function MatchCoding(nm As String, cmp As String)
Dim ld As Long, firstMatch As Boolean
firstMatch = (Left(nm, 1) = Left(cmp, 1))
ld = Levenshtein(nm, cmp)
Select Case ld
Case 0: MatchCoding = "Exact Match"
Case 1, 2: MatchCoding = "1-2 Letters off"
Case 3, 4: MatchCoding = "3-4 Letters off"
Case Else: MatchCoding = "5 or more Letters off, CHECK"
End Select
If ld > 0 And ld < 5 Then MatchCoding = MatchCoding & _
IIf(firstMatch, ", Same Starting Letter", "")
End Function
'utility sub for formatting headers
Sub doHeaders(rng As Range)
With rng
.Interior.Color = RGB(1, 139, 175)
.Font.Color = RGB(255, 255, 255)
.HorizontalAlignment = xlCenter
End With
End Sub

Sorting dates and display the recent ones VBA

I have the following list, I want to sort the dates and display the recent ones and stock them in ranges 21 and 22 like this:
I have successfully written this code that helped to do the sorting and display the recent dates and stock them on range 21, now I am stack and I dont know how to do to display the end date associated to each recent date.
Loop Until Not ech
' conversion of numbers into text for dico and listbox)
' and the false dates (written in text) to real dates
On Error GoTo PasDate
For i = 2 To UBound(t)
t(i, 1) = CStr(t(i, 1))
If TypeName(t(i, 2)) = "String" Then t(i, 2) = 1 * DateSerial(Right(t(i, 2), 4), Mid(t(i, 2), 4, 2), Left(t(i, 2), 2))
Next i
On Error Resume Next
'Fill dico
Set dico = CreateObject("scripting.dictionary")
dico.CompareMode = TextCompare
For i = 2 To UBound(t)
If t(i, 1) <> "" Then
If Not dico.Exists(t(i, 1)) Then
dico.Add t(i, 1), t(i, 2)
Else
If t(i, 2) > dico(t(i, 1)) Then dico(t(i, 1)) = t(i, 2)
End If
End If
Next i
'Transfert dico to the table r for the list
ReDim r(1 To dico.Count, 1 To 2): i = 0
For Each x In dico.Keys: i = i + 1: r(i, 1) = x: r(i, 2) = dico(x): Next
'fill ranges 20 and 21
.Range("b20:b21").Resize(, Columns.Count - 1).Clear
.Range("b20").Resize(1, UBound(r)).HorizontalAlignment = xlCenter
.Range("b21").Resize(1, UBound(r)).NumberFormat = "dd/mm/yyyy"
.Range("b20").Resize(2, UBound(r)).Borders.LineStyle = xlContinuous
.Range("b20:b21").Resize(2, UBound(r)) = Application.Transpose(r)
End With
'poplate the listbox
For i = 1 To UBound(r): r(i, 1) = Format(r(i, 2), "dd/mm/yyyy"): Next
'For i = 1 To UBound(r): r(i, 1) = Format(r(i, 1), "000"): r(i, 2) = Format(r(i, 2), "dd/mm/yyyy"): Next
With ListBox1
.ColumnCount = 2
.ColumnHeads = False
.ColumnWidths = .Width * 0.7 '& ";" & .Width * (1 - 0.6 + 0.1)
.List = r
End With
Exit Sub
'
PasDate:
Exit Sub
End
End Sub

Inefficient excel code breaks after few thousand lines of data

I am fairly new to Excel and VBA. I wrote a code that separates a line of data into multiple sections which then adds headers, colors, and plots.
The problem is when I have many lines of data. My code runs just fine when I have about 4000 lines of data, but I get say about 10000 lines, Excel freezes and does not respond anymore. The code is fairly long and I do expect anyone to read the entire thing.
My doubts are that excel does not respond and crashes because there is a watch-dog timer that times the execution of the code and if it does not receive anything back then it crashes. This is only a guess.
Here is a few lines of the actual data that I need to filter and everything.
2017:06:29T14:12:11,0,1013,00,156,-0.112,12.751,000,000,38,34,33,1014,00,202,-0.102,12.734,000,000,38,35,33,1015,00,174,-0.105,12.755,000,000,37,35,33,1008,00,156,-0.110,12.741,000,000,37,35,33,
2017:06:29T14:12:12,0,1013,00,157,-0.102,12.758,000,000,38,34,33,1014,00,203,-0.105,12.744,000,000,38,35,33,1015,00,175,-0.103,12.757,000,000,37,35,33,1008,00,157,-0.107,12.757,000,000,37,35,33,
2017:06:29T14:12:13,0,1013,00,158,-0.113,12.737,000,000,38,34,33,1014,00,204,-0.094,12.760,000,000,38,35,33,1015,00,176,-0.117,12.748,000,000,37,35,33,1008,00,158,-0.109,12.744,000,000,37,35,33,
2017:06:29T14:12:14,0,1013,00,159,-0.103,12.753,000,000,38,34,33,1014,00,205,-0.103,12.720,000,000,38,35,33,1015,00,177,-0.108,12.732,000,000,37,35,33,1008,00,159,-0.110,12.758,000,000,37,35,33,
2017:06:29T14:12:15,0,1013,00,160,-0.112,12.757,000,000,38,34,33,1014,00,206,-0.095,12.734,000,000,38,35,33,1015,00,178,-0.118,12.729,000,000,37,35,33,1008,00,160,-0.115,12.755,000,000,37,35,33,
I am open to any suggestions and more than happy to learn. Thank you for your time and help in advance.
Sub SeparateData()
'Author: Me
'Date: July 13, 2017
'Purpose: This macro take the data in the worksheet and separates the data in a readable fashion for the user.
' This macro also plots and reports any errors that it has caught both in separate sheets named accordingly.
'Define variables
Dim i As Variant
Dim j As Variant
Dim k As Variant
Dim data As Variant
Dim data2 As Variant
Dim count As Variant
Dim shiftDown As Variant
Dim monitorNum As Variant
Dim errorCount As Variant
Dim battChart As ChartObject
Dim currChart As ChartObject
Dim tempChart As ChartObject
'Stop the alerts so we can erase the sheets peacefully
Application.DisplayAlerts = False
'Erase the extra sheets
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
'Turn on the alerts in case something else happened
Application.DisplayAlerts = True
'Rename the first sheet
ActiveSheet.Name = "Data"
'Create a new sheet for the plots
Sheets.Add.Name = "Plots"
'Create a new sheet for the errors
Sheets.Add.Name = "Errors"
'Activate the first sheet for data processing
Worksheets("Data").Activate
'Enter the number of monitors
monitorNum = 4
'Variable to shift down the data so that te headers will fit (recommended 2)
shiftDown = 2
'Variable to count the number of errors the program thinks occured
errorCount = 0
'Count how many data point there are in the sheet
count = Cells(1, 1).CurrentRegion.Rows.count
'Iterate through the points separating the Data
For i = 0 To count - 1
'First separate the date from the rest
data = Cells(count - i, 1).Value
data = Split(data, "T")
For j = 0 To UBound(data)
Cells(count - i + shiftDown, j + 1).Value = data(j)
Next j
'Now separate the rest of the data
data2 = data(1)
data2 = Split(data2, ",")
For j = 0 To UBound(data2)
Cells(count - i + shiftDown, j + 2).Value = data2(j)
Next j
For k = 0 To monitorNum - 1
'Check for voltage error
If Cells(count - i + shiftDown, (k * 10) + 8).Value > 20 Or IsNumeric(Cells(count - i + shiftDown, (k * 10) + 8).Value) = False Then
'increment the number of errors found
errorCount = errorCount + 1
'Activate the Errors sheet for error recording
Worksheets("Errors").Activate
'Save the row number and the monitor number where the error was founf
Cells(errorCount, 1).Value = "Voltage error in row"
Cells(errorCount, 2).Value = count - i + shiftDown
Cells(errorCount, 3).Value = "in column"
Cells(errorCount, 4).Value = (k * 10) + 8
Cells(errorCount, 5).Value = "in Monitor"
Cells(errorCount, 6).Value = k + 1
Cells(errorCount, 7).Value = "The recorded data was"
Sheets("Data").Cells(count - i + shiftDown, (k * 10) + 8).Copy Cells(errorCount, 8)
'Autofit all the columns
Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
'Activate the first sheet for data processing
Worksheets("Data").Activate
'Clear the contents of the error
Cells(count - i + shiftDown, (k * 10) + 8).ClearContents
End If
'Check for current error
If Cells(count - i + shiftDown, (k * 10) + 7).Value > 80 Or IsNumeric(Cells(count - i + shiftDown, (k * 10) + 7).Value) = False Then
'increment the number of errors found
errorCount = errorCount + 1
'Activate the Errors sheet for error recording
Worksheets("Errors").Activate
'Save the row number and the monitor number where the error was founf
Cells(errorCount, 1).Value = "Current error in row"
Cells(errorCount, 2).Value = count - i + shiftDown
Cells(errorCount, 3).Value = "in column"
Cells(errorCount, 4).Value = (k * 10) + 7
Cells(errorCount, 5).Value = "in Monitor"
Cells(errorCount, 6).Value = k + 1
Cells(errorCount, 7).Value = "The recorded data was"
Sheets("Data").Cells(count - i + shiftDown, (k * 10) + 7).Copy Cells(errorCount, 8)
'Autofit all the columns
Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
'Activate the first sheet for data processing
Worksheets("Data").Activate
'Clear the contents of the error
Cells(count - i + shiftDown, (k * 10) + 7).ClearContents
End If
'Check for temperature error
If Cells(count - i + shiftDown, (k * 10) + 13).Value > 80 Or IsNumeric(Cells(count - i + shiftDown, (k * 10) + 13).Value) = False Then
'increment the number of errors found
errorCount = errorCount + 1
'Activate the Errors sheet for error recording
Worksheets("Errors").Activate
'Save the row number and the monitor number where the error was founf
Cells(errorCount, 1).Value = "Temperature error in row"
Cells(errorCount, 2).Value = count - i + shiftDown
Cells(errorCount, 3).Value = "in column"
Cells(errorCount, 4).Value = (k * 10) + 13
Cells(errorCount, 5).Value = "in Monitor"
Cells(errorCount, 6).Value = k + 1
Cells(errorCount, 7).Value = "The recorded data was"
Sheets("Data").Cells(count - i + shiftDown, (k * 10) + 13).Copy Cells(errorCount, 8)
'Autofit all the columns
Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
'Activate the first sheet for data processing
Worksheets("Data").Activate
'Clear the contents of the error
Cells(count - i + shiftDown, (k * 10) + 13).ClearContents
End If
Next k
Next i
'Erase the data that has been duplicated
For i = 1 To shiftDown
Cells(i, 1).Value = ""
Next i
'Write and color the headers
'For the Date
Range(Cells(shiftDown - 1, 1), Cells(shiftDown, 1)).Merge
Range(Cells(shiftDown - 1, 1), Cells(shiftDown, 1)).Value = "Date"
Range(Cells(shiftDown - 1, 1), Cells(count + shiftDown, 1)).Interior.Color = RGB(200, 190, 150)
'For the Time
Range(Cells(shiftDown - 1, 2), Cells(shiftDown, 2)).Merge
Range(Cells(shiftDown - 1, 2), Cells(shiftDown, 2)).Value = "Time"
Range(Cells(shiftDown - 1, 2), Cells(count + shiftDown, 2)).Interior.Color = RGB(150, 140, 80)
'For the Key Switch
Range(Cells(shiftDown - 1, 3), Cells(shiftDown, 3)).Merge
Range(Cells(shiftDown - 1, 3), Cells(shiftDown, 3)).Value = "Key Switch"
Range(Cells(shiftDown - 1, 3), Cells(count + shiftDown, 3)).Interior.Color = RGB(200, 200, 0)
For i = 1 To monitorNum
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Merge
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Value = "Monitor " & i
'color the headers
If i Mod 4 = 0 Then
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Interior.Color = RGB(100, 255, 100)
ElseIf i Mod 3 = 0 Then
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Interior.Color = RGB(255, 100, 10)
ElseIf i Mod 2 = 0 Then
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Interior.Color = RGB(100, 100, 255)
Else
Range(Cells(shiftDown - 1, ((i - 1) * 10) + 4), Cells(shiftDown - 1, (i * 10) + 3)).Interior.Color = RGB(255, 75, 75)
End If
Next i
For i = 0 To monitorNum - 1
'Monitor ID
Cells(shiftDown, 1 + (i * 10) + 3).Value = "MONITOR_NUM"
'Monitor status
Cells(shiftDown, 2 + (i * 10) + 3).Value = "MONITOR_STATUS"
'Heart Beat count
Cells(shiftDown, 3 + (i * 10) + 3).Value = "HB_COUNT"
'For Current
Cells(shiftDown, 4 + (i * 10) + 3).Value = "CURRENT"
Range(Cells(shiftDown, 4 + (i * 10) + 3), Cells(count + shiftDown, 4 + (i * 10) + 3)).Interior.Color = RGB(240, 150, 150)
'For Voltage
Cells(shiftDown, 5 + (i * 10) + 3).Value = "VOLTAGE"
Range(Cells(shiftDown, 5 + (i * 10) + 3), Cells(count + shiftDown, 5 + (i * 10) + 3)).Interior.Color = RGB(110, 160, 180)
'State of Charge
Cells(shiftDown, 6 + (i * 10) + 3).Value = "SOC"
'State of Health
Cells(shiftDown, 7 + (i * 10) + 3).Value = "SOH"
'Chip temperature
Cells(shiftDown, 8 + (i * 10) + 3).Value = "TEMP_CHP"
'Internal temperature
Cells(shiftDown, 9 + (i * 10) + 3).Value = "TEMP_INT"
'For Temperature of the terminal
Cells(shiftDown, 10 + (i * 10) + 3).Value = "TEMP_EXT"
Range(Cells(shiftDown, 10 + (i * 10) + 3), Cells(count + shiftDown, 10 + (i * 10) + 3)).Interior.Color = RGB(255, 190, 0)
Next i
'Add borders all around the data
Cells(shiftDown, 1).CurrentRegion.Borders.LineStyle = xlContinuous
'Autofit all the columns
Cells(shiftDown, 1).CurrentRegion.EntireColumn.AutoFit
'Plotting
'Activate the first sheet for data plotting
Worksheets("Data").Activate
'Add a new plot
Set battChart = Sheets("Plots").ChartObjects.Add(0, 0, 1200, 300)
'Plot the battery data
With battChart.Chart
.SetSourceData Source:=Sheets("Data").Range(Cells(5, 8), Cells(count + shiftDown, 8))
.SeriesCollection(1).Name = "Battery 1"
.ChartWizard Title:="Voltage", HasLegend:=True, CategoryTitle:="Time (s)", ValueTitle:="Voltage (V)", Gallery:=xlXYScatterLinesNoMarkers
For i = 2 To monitorNum
.SeriesCollection.NewSeries
.SeriesCollection(i).Values = Sheets("Data").Range(Cells(5, ((i - 1) * 10) + 8), Cells(count + shiftDown, ((i - 1) * 10) + 8))
.SeriesCollection(i).Name = "Battery " & i
Next i
End With
'Add a new plot
Set currChart = Sheets("Plots").ChartObjects.Add(0, 300, 1200, 300)
'Plot the current data
With currChart.Chart
.SetSourceData Source:=Sheets("Data").Range(Cells(5, 7), Cells(count + shiftDown, 7))
.SeriesCollection(1).Name = "Battery 1"
.ChartWizard Title:="Current", HasLegend:=True, CategoryTitle:="Time (s)", ValueTitle:="Current (A)", Gallery:=xlXYScatterLinesNoMarkers
For i = 2 To monitorNum
.SeriesCollection.NewSeries
.SeriesCollection(i).Values = Sheets("Data").Range(Cells(5, ((i - 1) * 10) + 7), Cells(count + shiftDown, ((i - 1) * 10) + 7))
.SeriesCollection(i).Name = "Battery " & i
Next i
End With
'Add a new plot
Set tempChart = Sheets("Plots").ChartObjects.Add(0, 600, 1200, 300)
'Plot the current data
With tempChart.Chart
.SetSourceData Source:=Sheets("Data").Range(Cells(5, 13), Cells(count + shiftDown, 13))
.SeriesCollection(1).Name = "Battery 1"
.ChartWizard Title:="Temperature", HasLegend:=True, CategoryTitle:="Time (s)", ValueTitle:="Temperature (F)", Gallery:=xlXYScatterLinesNoMarkers
For i = 2 To monitorNum
.SeriesCollection.NewSeries
.SeriesCollection(i).Values = Sheets("Data").Range(Cells(5, ((i - 1) * 10) + 13), Cells(count + shiftDown, ((i - 1) * 10) + 13))
.SeriesCollection(i).Name = "Battery " & i
Next i
End With
'Indicate that the macro has finished its job
Beep
MsgBox "Data separation is complete. There were " & errorCount & " errors found."
End Sub

All of your Worksheets("x").Activate are totally unnecessary, are slowing your code significantly and are begging for inexplicable errors later when you forget to activate the correct sheet or your bored user starts clicking around during execution because it's taking too long. Declare some Worksheet variables and work with those.
Dim DataSheet as Worksheet
ActiveSheet.Name = "Data"
Set DataSheet = ActiveSheet
Dim PlotSheet as Worksheet
Set PlotSheet as Worksheets.Add
Plotsheet.Name = "Plots"
Dim ErrorSheet as Worksheet
Set ErrorSheet = Worksheets.Add
ErrorSheet.Name = "Errors"
count = Datasheet.Cells(1, 1).CurrentRegion.Rows.count
'GET RID OF THIS EVERYWHERE!!! Worksheets("Errors").Activate
'Save the row number and the monitor number where the error was founf
With ErrorSheet
.Cells(errorCount, 1).Value = "Voltage error in row"
.Cells(errorCount, 2).Value = count - i + shiftDown
.Cells(errorCount, 3).Value = "in column"
.Cells(errorCount, 4).Value = (k * 10) + 8
.Cells(errorCount, 5).Value = "in Monitor"
.Cells(errorCount, 6).Value = k + 1
.Cells(errorCount, 7).Value = "The recorded data was"
'Note subtle change here:
DataSheet.Cells(count - i + shiftDown, (k * 10) + 8).Copy .Cells(errorCount, 8)
'Note: explicitly setting "datasheet" as the destination and using the "With" to save some typing on the ".Cells" call.
'You could explicitly type the "ErrorSheet" to make it more clear
'an even better version is:
.cells(errorCount, 8) = DataSheet.Cells(count - i + shiftDown, (k * 10) + 8)
End With
Continue to do that everywhere. Future you will appreciate current you...
Every time you're doing a Sheet("x").Activate eliminate that line and explicitly add a reference to the appropriate worksheet variable you declared earlier.
Every time you have an unqualified Sheets or Cells or Range call, make it an explicit reference by prepending the appropriate worksheet variable. Future you will appreciate the fact that you can see exactly what worksheet you're referencing. Sure, there may be some extra typing involved, but that extra typing significantly reduces the chance of inserting very subtle and difficult to find bugs.
Using .Copy is very slow for single cells. It does gain a speed advantage if you're copying large blocks of cells in a single go (somewhere in the neighborhood of 3-5k cells in a single copy statement vs a loop through setting individual cell values).
As Uri Goren pointed out setting Application.Calculation = False will definitely improve your speed. I'd recommend not setting Application.ScreenUpdating = False until after your code is 100% functional and not generating any errors. Once you're at that point, it's a great thing to do.
At this point in your code you may want to add the indicated line:
'Iterate through the points separating the Data
For i = 0 To count - 1
'Add this line:
Application.StatusBar = "Separating points #" & i
Put a similar message just inside the top of each of your large loops. You'll likely see that your code isn't hanging, just taking a long time to process. Plus you'll have an update that your user can watch so (s)he'll know it isn't hung and is still doing something.
At the end of your code put:
Application.StatusBar = ""
To clear the message so you get your normal Excel StatusBar functionality returned.

Add these two lines at the beginning of the subroutine:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
And these 2 lines before the end of the subroutine
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
It should speed up your code significantly

Increment value within range until corresponding cell value increases by specified amount

I have this problem to be sorted out. Namely, I need the code that will place the same values in the range until corresponding cells value increases by one. Once it does the value needs to be incremented by 0.2 and place incremented number until again the corresponding cell value is higher by one
Sub Button4_Click()
range1 = Sheets(3).Range("g2").End(xlDown).Row
range2 = "g2:g" & range1
For i = 2 To range1
If Cells(i, 7).Value <= 360 Then
Cells(i, 8) = 60
range3_n = Cells(i, 8).Row
End If
Next
j = 0.2
k = 1
For i = range3_n To range1
If Cells(i, 7) > 360 And Cells(i, 7) <= (360 + k) And Cells(i, 7) <= (360 +
100) Then
Cells(i, 8) = 60 + (k * j)
k = k + 1
End If
Next
MsgBox ("END")
End Sub

Based on the comments, and keeping the code structure the exact same as it is, an easy solution is adding a new IF Statement after your last one:
IF (Cells(i, 7) - Int(Cells(i, 7)) = 0) Then
The code should look like:
Sub Button4_Click()
range1 = Sheets(1).Range("g2").End(xlDown).Row
range2 = "g2:g" & range1
For i = 2 To range1
If Cells(i, 7).Value <= 360 Then
Cells(i, 8) = 60
range3_n = Cells(i, 8).Row
End If
Next
range3_n = range3_n + 1 'start at cell 361 instead
j = 0.2
k = 1
For i = range3_n To range1
If Cells(i, 7) > 360 And Cells(i, 7) <= (361 + k) And Cells(i, 7) <= (360 + 100) Then
If Int(Cells(i - 1, 7)) - Int(Cells(i, 7)) <> 0 Then
Cells(i, 8) = 60 + (k * j)
k = k + 1
Else
Cells(i, 8) = Cells(i - 1, 8)
End If
End If
Next i
MsgBox ("END")
End Sub
What this does is, it takes the value of the cell, subtracts the integer version of that value (360.1 = 360, 365.4 = 365, etc.) and ensures that equals zero. Any decimal value > .0 will fail, and will not meet the criteria.
Example:
360.0 - 360 = 0 PASS
360.1 - 360 = .1 FAIL
360.4 - 360 = .4 FAIL
360.7 - 360 = .7 FAIL
361.0 - 361 = 0 PASS
Try it out and let me know.

Compare the first 3 cells of three columns in excel

Hello I have three columns with filled with names. So far I need to extract the three first cells of each column and put all the 15 names into a forth column. But if there are duplicates I must not put them in the list.
So far I got into
Private Sub CommandButton1_Click()
Dim temp(15) As String
Dim array1(5) As String
Dim array2(5) As String
Dim array3(5) As String
Dim i As Integer
Dim j As Integer
For i = 1 To 5
array1(i) = Cells(i + 3, 1).Value
array2(i) = Cells(i + 3, 4).Value
array3(i) = Cells(i + 3, 7).Value
Next i
temp(1) = array1(1)
temp(2) = array1(2)
temp(3) = array1(3)
temp(4) = array1(4)
temp(5) = array1(5)
temp(6) = array2(1)
temp(7) = array2(2)
temp(8) = array2(3)
temp(9) = array2(4)
temp(10) = array2(5)
temp(11) = array3(1)
temp(12) = array3(2)
temp(13) = array3(3)
temp(14) = array3(4)
temp(15) = array3(5)
For i = 1 To 15
For j = 1 To 15
If (temp(i) = temp(j + 1)) Then
Else
Cells(i + 4, 10).Value = temp(i)
End If
Next j
j = 0
Next i
End Sub

For i = 1 to 3
Cells(6 * i - 5, 10).Resize(5, 1).Value = Cells(6 * i - 5, 4 * i - 3).Resize(5,1).Value
Next
Application.DisplayAlerts = False
Cells(1, 10).Resize(15, 1).RemoveDuplicates Columns:=1, Header:=xlNo
Application.DisplayAlerts = True

Resources