Sub GetMaxl()
Dim nMonths As Integer, nRegions As Integer
Dim iRow As Integer, iCol As Integer
Dim regionMax As Double, monthMax As Double
Dim maxScore As Integer
With wsSales.Range("A3")
nMonths = Range(.Offset(0, 1), .Offset(0, 1).End(xlToRight)) _
.Columns.Count
nRegions = Range(.Offset(1, 0), .Offset(1, 0).End(xlDown)) _
.Rows.Count
.Offset(0, nMonths + 1) = "MaxScore"
.Offset(nRegions + 1, 0) = "MaxScore"
For iRow = 1 To nRegions
regionMax = 0
For iCol = 1 To nMonths
regionMax = WorksheetFunction.Max(Range(.Offset(iRow, iCol), .End(xlToRight)))
Debug.Print , regionMax
Next iCol
.Offset(iRow, nMonths + 1) = regionMax
Next iRow
For iCol = 1 To nMonths
monthMax = 0
For iRow = 1 To nRegions
monthMax = WorksheetFunction.Max(Range(.Offset(iRow, iCol), .End(xlDown)))
Next iRow
.Offset(nRegions + 1, iCol) = monthMax
Next iCol
End With
End Sub
I am trying to get the max score against columns and rows in a loop but I am not getting correct results.
It can be done easier and faster
Option Explicit
Sub GetMaxl()
Dim Rng As Range, rng_total_right As Range, rng_total_down As Range
Set Rng = wsSales.Range("A3").CurrentRegion
'get the ranges for max column and row at right and down
Set rng_total_right = Intersect(Rng.Offset(, 1), wsSales.Columns(Rng.Column + Rng.Columns.Count))
Set rng_total_down = Intersect(Rng.Offset(1, 0), wsSales.Rows(Rng.Row + Rng.Rows.Count))
With rng_total_right ' max column
.NumberFormat = "0"
.FormulaR1C1 = "=MAX(RC[-" & Rng.Columns.Count - 1 & "]:RC[-1])" ' insert formulas and calculate them
.Value = .Value 'replace formulas by values
.Cells(1) = "MaxScore" 'make header
End With
With rng_total_down 'max row
.NumberFormat = "0"
.FormulaR1C1 = "=MAX(R[-" & Rng.Rows.Count - 1 & "]C:R[-1]C)"
.Value = .Value
.Cells(1) = "MaxScore"
End With
End Sub
I have a data like this :
A049
A050
A051
A053
A054
A055
A056
A062
A064
A065
A066
And I want the output like :
As you can see, I want the ranges which are in consecutive order
I am trying some thing like this:
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
For i = 2 To lastRow
r = wb.Sheets("Sheet1").Range("A" & i).Value
If wb.Sheets("Sheet1").Range("A" & i).Value = wb.Sheets("Sheet1").Range("A" & i+1).Value
Next i
End Sub
But not helping me
Am feeling charitable so have tried some code which should work. It assumes your starting values are in A1 down and puts results in C1 down.
Sub x()
Dim v1, v2(), i As Long, j As Long
v1 = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
ReDim v2(1 To UBound(v1, 1), 1 To 2)
For i = LBound(v1, 1) To UBound(v1, 1)
j = j + 1
v2(j, 1) = v1(i, 1)
If i <> UBound(v1, 1) Then
Do While Val(Right(v1(i + 1, 1), 3)) = Val(Right(v1(i, 1), 3)) + 1
i = i + 1
If i = UBound(v1, 1) Then
v2(j, 2) = v1(i, 1)
Exit Do
End If
Loop
End If
If v1(i, 1) <> v2(j, 1) Then v2(j, 2) = v1(i, 1)
Next i
Range("C1").Resize(j, 2) = v2
End Sub
Try the below code
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
Dim lastNum, Binsert As Integer
Dim firstCell, lastCell, currentCell As String
Binsert = 1
lastNum = getNum(wb.Sheets("Sheet1").Range("A1").Value)
firstCell = wb.Sheets("Sheet1").Range("A1").Value
For i = 2 To lastRow
activeNum = getNum(wb.Sheets("Sheet1").Range("A" & i).Value)
currentCell = wb.Sheets("Sheet1").Range("A" & i).Value
If (activeNum - lastNum) = 1 Then
'nothing
Else
lastCell = wb.Sheets("Sheet1").Range("A" & (i - 1)).Value
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> lastCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = lastCell
End If
Binsert = Binsert + 1
firstCell = wb.Sheets("Sheet1").Range("A" & i).Value
End If
lastNum = activeNum
Next i
'last entry
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> currentCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = currentCell
End If
End Sub
Public Function getNum(ByVal num As String) As Integer
getNum = Val(Mid(num, 2))
End Function
Another solution. It loops backwards from last row to first row.
Option Explicit
Public Sub FindConsecutiveValues()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long 'find last row
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim lVal As String 'remember last value (stop value)
lVal = ws.Range("A" & lRow).Value
Const fRow As Long = 2 'define first data row
Dim i As Long
For i = lRow To fRow Step -1 'loop from last row to first row backwards
Dim iVal As Long
iVal = Val(Right(ws.Range("A" & i).Value, Len(ws.Range("A" & i).Value) - 1)) 'get value of row i without A so we can calculate
Dim bVal As Long
bVal = 0 'reset value
If i <> fRow Then 'if we are on the first row there is no value before
bVal = Val(Right(ws.Range("A" & i - 1).Value, Len(ws.Range("A" & i - 1).Value) - 1)) 'get value of row i-1 without A
End If
If iVal - 1 = bVal Then
ws.Rows(i).Delete 'delete current row
Else
If lVal <> ws.Range("A" & i).Value Then 'if start and stop value are not the same …
ws.Range("B" & i).Value = lVal 'write stop value in column B
End If
lVal = ws.Range("A" & i - 1).Value 'remember now stop value
End If
Next i
End Sub
I'm trying to run a compare though multiple sheets.
I get
Runtime error 9 subscript out of range
Sub Comp_TEST()
Dim ar As Variant
Dim var()
Dim i As Long
Dim n As Long
Dim Last_Row As Long
Dim WS As Worksheet
For Each WS In ActiveWorkbook.Worksheets
If WS.Name <> "GALVANISED" And WS.Name <> "ALUMINUM" And WS.Name <> "LOTUS" And WS.Name <> "TEMPLATE" And WS.Name <> "SCHEDULE CALCULATIONS" And WS.Name <> "TRUSS" And WS.Name <> "DASHBOARD CALCULATIONS" And WS.Name <> "GALVANISING CALCULATIONS" Then
WS.Range("D3:D1000").Copy
WS.Range("O3").PasteSpecial xlPasteValues
WS.Range("K3:K1000").Copy
WS.Range("N3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
ar = WS.Range("N3").CurrentRegion
ReDim var(1 To UBound(ar, 1), 1 To 1)
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 1 To UBound(ar, 1)
.Item(ar(i, 2)) = Empty
Next
For i = 1 To UBound(ar, 1)
If Not .exists(ar(i, 1)) Then
n = n + 1
var(n, 1) = ar(i, 1) 'error happens here
End If
Next
End With
WS.[P3].Resize(n).Value = var
Erase var
ReDim var(1 To UBound(ar, 1), 1 To 1)
Last_Row = WS.Range("D2").End(xlDown).Offset(1).Row
WS.Range("P3:P1000").Copy
WS.Range("D" & Last_Row).PasteSpecial xlPasteValues
WS.Range("N3:P1000").ClearContents
End If
Next WS
End Sub
The following works but then I need to make a Sub for at the moment 26 sheets which could be more later. I don't want to make another Sub each time that happens.
Or I may also need to delete a sheet then I would have delete that Sub.
Sub Comp_ALL_VANS()
Dim ar As Variant
Dim var()
Dim i As Long
Dim n As Long
Dim Last_Row As Long
Worksheets("ALL VANS").Range("D3:D1000").Copy
Worksheets("ALL VANS").Range("O3").PasteSpecial xlPasteValues
Worksheets("ALL VANS").Range("K3:K1000").Copy
Worksheets("ALL VANS").Range("N3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
ar = Worksheets("ALL VANS").Range("N3").CurrentRegion
ReDim var(1 To UBound(ar, 1), 1 To 1)
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 1 To UBound(ar, 1)
.Item(ar(i, 2)) = Empty
Next
For i = 1 To UBound(ar, 1)
If Not .exists(ar(i, 1)) Then
n = n + 1
var(n, 1) = ar(i, 1)
End If
Next
End With
Worksheets("ALL VANS").[P3].Resize(n).Value = var
Last_Row = Worksheets("ALL VANS").Range("D2").End(xlDown).Offset(1).Row
Worksheets("ALL VANS").Range("P3:P1000").Copy
Worksheets("ALL VANS").Range("D" & Last_Row).PasteSpecial xlPasteValues
Worksheets("ALL VANS").Range("N3:P1000").ClearContents
End Sub
Option Explicit
Sub Comp_TEST()
Dim ws As Worksheet, n As Long
Dim arSkip
arSkip = Array("GALVANISED", "ALUMINUM", "LOTUS", "TEMPLATE", "SCHEDULE CALCULATIONS", _
"TRUSS", "DASHBOARD CALCULATIONS", "GALVANISING CALCULATIONS")
For Each ws In ActiveWorkbook.Worksheets
If IsError(Application.Match(ws.Name, arSkip, 0)) Then
Call process(ws)
n = n + 1
Else
Debug.Print "Skipped " & ws.Name
End If
Next
MsgBox n & " sheets processed", vbInformation
End Sub
Sub process(ws As Worksheet)
Dim dict As Object, k As String, arK, arD, arNew
Dim n As Long, i As Long, LastRowD As Long, LastRowK as Long
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = 1
With ws
LastRowK = .Cells(.Rows.Count, "K").End(xlUp).Row
If LastRowK < 4 Then LastRowK = 4 ' ensure 2 cells for array
arK = .Range("K3:K" & LastRowK)
LastRowD = .Cells(.Rows.Count, "D").End(xlUp).Row
If LastRowD <= 3 Then
arD = .Range("D3:D4") ' ensure 2 cells for array
If LastRowD < 2 Then LastRowD = 2
Else
arD = .Range("D3:D" & LastRowD)
End If
End With
' array for new
ReDim arNew(1 To UBound(arK), 1 To 1)
' fill dictionary from col D
For i = 1 To UBound(arD)
k = arD(i, 1)
If dict.exists(k) Then
MsgBox "Duplicate key '" & k & "' at D" & i + 2, vbCritical, "Error " & ws.Name
Exit Sub
ElseIf Len(k) > 0 Then
dict.Add k, i
End If
Next
' compare col K with col D
n = 0
For i = 1 To UBound(arK)
k = arK(i, 1)
If Not dict.exists(k) Then
n = n + 1
arNew(n, 1) = k
End If
Next
' result
If n > 0 Then
ws.Range("D" & LastRowD + 1).Resize(n) = arNew
End If
End Sub
first post and also new to VBA so I apologize for anything that is unclear. I have created a code to generate a daily printout of employees, equipment, and subcontractors. The loop is looking for "S" (subcontractors) each day. There is only one day where "S" is present and there are 4 on that day. The issue is that the loop begins correctly and populates the correct information when it finds "S" and lists the 4 separate subcontractors, but every day before and after that it continues to list the first subcontractor even though no "S" is found on those dates. How can I get it to clear that entry if no other "S" are found? I hope that makes sense and I have included the code. Thank you!
Screesnhot
Sub WriteReport_Click()
Dim EachName(1 To 5000) As Variant
Dim NameHours(1 To 5000) As Variant
Dim NamePhase(1 To 5000) As Variant
Dim EquipHours(1 To 5000) As Variant
Dim EquipPhase(1 To 5000) As Variant
Dim EachDate(1 To 5000) As Date
Dim EachEquip(1 To 5000) As Variant
Dim EachSub(1 To 5000) As Variant
Dim SubAmount(1 To 5000) As Variant
Dim i As Long 'loop through records
Dim k As Integer 'count employees
Dim h As Integer 'count equipment
Dim t As Integer 'count subcontractor
Dim m As Integer 'count dates
Dim j As Integer
Dim x As Integer
Dim lr, s, p, StartBorder, EndBorder As Integer 'keeps row counts Start & Finish
Dim TestString As String
Sheets("Data").Activate
k = 1 'counts EachName
h = 1 'counts EachEquip
t = 1 'counts EachSub
m = 1 'counts dates
lr = 1
p = 0
For i = 1 To Rows.Count
If Cells(i, 3) = "L" Then
EachName(1) = Cells(i, 11)
Exit For
End If
Next i
For i = 1 To Rows.Count
If Cells(i, 3) = "E" Then
EachEquip(1) = Cells(i, 12)
Exit For
End If
Next i
For i = 1 To Rows.Count
If Cells(i, 3) = "S" Then
EachSub(1) = Cells(i, 9)
Exit For
End If
Next i
NameHours(1) = 0
EquipHours(1) = 0
EachDate(1) = Cells(1, 1)
SubAmount(1) = 0
Dim LastRow As Integer
For i = 1 To 5000
If EachDate(m) <> Cells(i, 1) Then
m = m + 1 'setting array for next new date
EachDate(m) = Cells(i, 1)
lr = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row + 1
StartBorder = lr
Sheets("Report").Cells(lr, 1) = Format(EachDate(m - 1), "mm/dd/yy") 'prints date
Sheets("Report").Cells(lr, 1).Interior.ColorIndex = 4 'highlights date
For j = 1 To k 'prints employees, hours and phase
Sheets("Report").Cells((lr + j), 1) = EachName(j)
Sheets("Report").Cells((lr + j), 2) = NameHours(j)
Sheets("Report").Cells((lr + j), 4) = NamePhase(j)
Sheets("Report").Cells((lr + j), 5).Formula = _
"=IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",Employee,2,FALSE),"""")"
Next j
k = 1
lr = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row + 1
For s = i To 5000 'getting first employee for next date
If Cells(s, 1) = EachDate(m) And Cells(s, 3) = "L" Then
EachName(1) = Cells(s, 11)
Exit For
End If
Next s
Erase NameHours 'clearing manhours for next date
For j = 1 To h
Sheets("Report").Cells((lr + j), 1) = Trim(EachEquip(j))
Sheets("Report").Cells((lr + j), 3) = EquipHours(j)
Sheets("Report").Cells((lr + j), 4) = EquipPhase(j)
Sheets("Report").Cells((lr + j), 5).Formula = _
"=LEFT(IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",EquipList,2,FALSE),""""),20)"
Next j
h = 1
For s = i To 5000 'getting first equipment for next date
If Cells(s, 1) = EachDate(m) And Cells(s, 3) = "E" Then
EachEquip(1) = Cells(s, 12)
Exit For
End If
Next s
Erase EquipHours ' clearing equipment hours for next date
lr = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row + 1
For x = 1 To t
Sheets("Report").Cells((lr + x), 1) = EachSub(x)
Sheets("Report").Cells((lr + x), 3) = SubAmount(x)
Next x
For x = i To 5000 'getting subcontractor for next date
If Cells(x, 1) = EachSub(m) And Cells(x, 3) = "S" Then
EachSub(1) = " "
Exit For
End If
Next x
EndBorder = lr + x
t = 1
With Worksheets("Report") 'draws borders
.Range(.Cells(StartBorder, 1), .Cells(EndBorder, 8)).BorderAround ColorIndex:=1, Weight:=xlThick
End With
End If
Select Case Cells(i, 3).Value
Case "L"
If Cells(i, 11) = EachName(k) Then
If Cells(i, 7) = 0 Then
p = p + 1 'adding up per diem
End If
NamePhase(k) = Cells(i, 2)
NameHours(k) = NameHours(k) + Cells(i, 7)
Else
k = k + 1
EachName(k) = Cells(i, 11)
NamePhase(k) = Cells(i, 2)
If Cells(i, 7) = 0 Then
p = p + 1
End If
NameHours(k) = NameHours(k) + Cells(i, 7)
End If
Case "E"
If Cells(i, 12) = EachEquip(h) Then
EquipPhase(h) = Cells(i, 2)
EquipHours(h) = EquipHours(h) + Cells(i, 7)
Else
h = h + 1
EachEquip(h) = Cells(i, 12)
EquipPhase(h) = Cells(i, 2)
EquipHours(h) = EquipHours(h) + Cells(i, 7)
End If
Case "S"
If Cells(i, 9) = EachSub(t) Then
EachSub(t) = Cells(i, 9)
SubAmount(t) = SubAmount(t) + Cells(i, 8)
Else
t = t + 1
EachSub(t) = Cells(i, 9)
SubAmount(t) = SubAmount(t) + Cells(i, 8)
End If
End Select
Next i
MsgBox "Report Completed !!!"
End Sub
You will find your code easier to debug/maintain if you separate the collection of the data and the report generation into 2 discrete steps, preferably in subroutines. For example
Option Explicit
Dim EachName(0 To 5000, 1 To 3) As Variant '1=name 2=hours 3=phase
Dim EachEquip(0 To 5000, 1 To 3) As Variant '1=name 2=hrs 3=phase
Dim EachSub(0 To 5000, 1 To 2) As Variant ' 1=name 2=amount
Dim k As Long 'count employees
Dim h As Long 'count equipment
Dim t As Long 'count subcontractor
Sub WriteReport_Click()
' specify book and sheets to process
Dim wb As Workbook, wsData As Worksheet, wsRep As Worksheet
Set wb = ThisWorkbook ' or ActiveWorkBook
' determine extent of data
Dim LastRow As Long, iRow As Long
Set wsData = wb.Sheets("Data")
LastRow = wsData.Cells(Rows.Count, 1).End(xlUp).Row
' clear report sheet
Set wsRep = wb.Sheets("Report")
wsRep.Cells.Clear
' scan data for first date
Dim RepDate As Date
RepDate = wsData.Cells(1, 1)
Call GetData(RepDate, wsData)
' scan data for more dates
For iRow = 1 To LastRow
If wsData.Cells(iRow, 1) <> RepDate Then
' report existing date
Call ReportData(RepDate, wsRep)
' get data for new date
RepDate = wsData.Cells(iRow, 1)
Call GetData(RepDate, wsData)
End If
Next
' report last date
Call ReportData(RepDate, wsRep)
'end
wsRep.Columns("A:E").AutoFit
MsgBox "Report Completed", vbInformation, LastRow & " rows scanned"
End Sub
Sub ReportData(d As Date, ws As Worksheet)
Debug.Print "ReportData", d
Dim lr As Long, StartBorder As Long, EndBorder As Long, j As Long
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
StartBorder = lr
ws.Cells(lr, 1) = Format(d, "mm/dd/yy") 'prints date
ws.Cells(lr, 1).Interior.ColorIndex = 4 'highlights date
'prints employees, hours and phase
For j = 1 To k
ws.Cells((lr + j), 1) = EachName(j, 1) 'empoyee name
ws.Cells((lr + j), 2) = EachName(j, 2) 'hrs
ws.Cells((lr + j), 4) = EachName(j, 3) 'phase
ws.Cells((lr + j), 5).Formula = _
"=IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",Employee,2,FALSE),"""")"
Next j
' report equipment
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
For j = 1 To h
ws.Cells((lr + j), 1) = EachEquip(j, 1) 'equip name
ws.Cells((lr + j), 3) = EachEquip(j, 2) 'hours
ws.Cells((lr + j), 4) = EachEquip(j, 3) 'phase
ws.Cells((lr + j), 5).Formula = _
"=LEFT(IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",EquipList,2,FALSE),""""),20)"
Next j
' report sub contractors
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
For j = 1 To t
ws.Cells((lr + j), 1) = EachSub(j, 1) 'sub name
ws.Cells((lr + j), 3) = EachSub(j, 2) 'amount
Next j
' draws borders
EndBorder = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range(ws.Cells(StartBorder, 1), ws.Cells(EndBorder, 8)) _
.BorderAround ColorIndex:=1, Weight:=xlThick
End Sub
Sub GetData(d As Date, ws As Worksheet)
Debug.Print "GetData", d
Dim LastRow As Long, i As Long
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
' clear global arrays
Erase EachName
Erase EachEquip
Erase EachSub
k = 0: h = 0: t = 0
For i = 1 To LastRow
If ws.Cells(i, 1) = d Then
Select Case ws.Cells(i, 3)
Case "L" ' Employee
If ws.Cells(i, 11) <> EachName(k, 1) Then
k = k + 1
End If
EachName(k, 1) = ws.Cells(i, 11)
EachName(k, 2) = ws.Cells(i, 7) + EachName(k, 2) ' hours
EachName(k, 3) = ws.Cells(i, 2) ' phase
Case "E" ' Equipment
If ws.Cells(i, 12) <> EachEquip(h, 1) Then
h = h + 1
End If
EachEquip(h, 1) = Trim(ws.Cells(i, 12)) ' equip name
EachEquip(h, 2) = ws.Cells(i, 7) + EachEquip(h, 2) ' hours
EachEquip(h, 3) = ws.Cells(i, 2) ' phase
Case "S" ' Subcontractor
If ws.Cells(i, 9) <> EachSub(t, 1) Then
t = t + 1
End If
EachSub(t, 1) = ws.Cells(i, 9) ' sub name
EachSub(t, 2) = ws.Cells(i, 8) + EachSub(t, 2) ' amount
Case Else
MsgBox "Unknown code at row " & i, vbExclamation
End Select
End If
Next
End Sub
I have created a possapp for my bar. Everything works fine but i have to recalculate the listbox when delete 1 or more items.
This is my code for the delete button
Private Sub CommandButton84_Click()
Dim ItemTarget&, s, i%
s = 0
ItemTarget = ListBox1.ListCount
If ItemTarget > 0 Then
Me.ListBox1.RemoveItem ItemTarget - 1
For i = 0 To Me.ListBox1.ListCount - 1
s = s + Val(Me.ListBox1.List(i, 1))
Next
Me.TextBox1 = s
Else
MsgBox "De lijst is reeds leeg", vbInformation, "Café De Zoete Inval"
End If
Me.TextBox4 = Me.ListBox1.ListCount
End Sub
Private Sub CommandButton100_Click()
Dim LItem As Long
Dim IRange As Integer
Dim sht As Worksheet
Dim LastRow As Long
Dim rows As Integer
rows = 0
Set sht = ActiveSheet
For LItem = 0 To ListBox1.ListCount - 1
ListBox1.ColumnCount = 2
With Worksheets("Sheet6")
.Cells(LItem + 7, 1) = ListBox1.List(LItem, 0)
.Cells(LItem + 7, 2) = ListBox1.List(LItem, 1)
.Cells(LItem + 8, 1).EntireRow.Insert
rows = rows + 1
End With
With Sheets("Histo")
LastRow = .Cells.Find("*", searchorder:=xlByRows,
searchdirection:=xlPrevious).Row
If Time < "07:00:00" Then
.Cells(LastRow + 1, 1) = Format(Date - 1, "dd-mm-yyyy")
Else
.Cells(LastRow + 1, 1) = Date
End If
.Cells(LastRow + 1, 2) = ListBox1.List(LItem, 0)
.Cells(LastRow + 1, 3) = ListBox1.List(LItem, 1)
End With
Next LItem
With ThisWorkbook.Sheets("Sheet6")
ListBox1.Clear
TextBox2.Value = ""
TextBox1.Value = 0
Range("Sheet6!B5").ClearContents
For i = 1 To rows
.Cells(7, 1).EntireRow.Delete
Next
End With
ActiveWorkbook.Save
End Sub
Private Sub CommandButton1_Click()
With ThisWorkbook.Sheets("Sheet1")
Me.ListBox1.AddItem .Range("B2").Value
Me.ListBox1.Column(1, ListBox1.ListCount - 1) = Format(Val(.Range("C2").Value),
"€#,##0.00")
Me.TextBox1.Value = CDbl(Me.TextBox1.Value) + .Range("C2").Value
Me.TextBox1.Value = Format(Me.TextBox1.Value, "#,##0.00")
End With
Me.TextBox4 = Me.ListBox1.ListCount
End Sub