I have had to open a new question following a previous question i had to decrease and increment a number which is on the link bellow
Changing VBA macro code to change number
this is the code that i am trying to work with and i got it almost to work but somewhere its gone wrong.
Bulkwks.[B5] is M20
historywks.[a2] is the time
historywks.[b2] is the name
historywks.[C2] is m201001
Sub bulkON_Click()
Dim trnwkbk As Workbook
Dim Bulkwks As Worksheet
Dim Deswkbk As Workbook
Dim LogNum As Range, LastNum, NewNum,
Dim historywks As Worksheet
Dim nextRow As Long
Dim lOR As Long
Dim myIn As String
Dim myLeft As String
Dim myMid As Integer, myRight As Integer, i As Integer
Dim myOut As String
Set trnwkbk = Workbooks("Transport.xls")
Set Bulkwks = trnwkbk.Worksheets("Bulk")
lOR = MsgBox("Have you selected the right MIS or HUB or PSA number?", vbQuestion + vbYesNo, "Number Order")
If lOR = vbNo Then
MsgBox "Please select right Order Number"
Else
Application.ScreenUpdating = False
' for testing i just made it post in test sheet in same workbook
'Set Deswkbk = Workbooks.Open("\\dunton01\Inspections\TRANSPORT\New_transport\data\Febuary_2013.xls")
'Set historywks = Deswkbk.Worksheets("Data")
Set historywks = Worksheets("test")
Set LogNum = historywks.[C2]
With historywks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
If LogNum(2, 1) = "" Then
LastNum = LogNum
Else
LastNum = LogNum(LogNum.End(xlDown).Row - 1, 1)
End If
NewNum = Bulkwks.[B5] & Val(Mid(LastNum, 2)) + 1
If LogNum(2, 1) = "" Then
LogNum(2, 1) = NewNum
Else
myIn = LogNum
myLeft = Left(myIn, 1)
myMid = CInt(Mid(myIn, 2, 2))
myRight = CInt(Right(myIn, 4))
myOut = myLeft & Format(myMid, "00") & Format(myRight, "0000")
i = 0
Debug.Print "IN: " & myIn
Debug.Print "BROKEN UP: " & myOut
Do Until myMid = -1
Debug.Print "ITERATION " & Format(i, "00") & ": " & myLeft & Format(myMid, "00") & Format(myRight, "0000")
myMid = myMid - 1
myRight = myRight + 1
myOut = myLeft & Format(myMid, "00") & Format(myRight, "0000")
i = i + 1
With historywks
'enter date and time stamp in record
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
'enter user name in column B
.Cells(nextRow, "B").Value = Application.UserName
.Cells(nextRow, "C").Value = myIn
End With ' for testing i just disabled this Deswkbk.save
Loop
' for testing i just disabled this
'Deswkbk.Close savechanges:=True
Application.ScreenUpdating = True
Bulkwks.[E3] = NewNum
End If
' for testing i just disabled this
'Call File_In_Network_Folder
End If
End Sub
You'll need to use the myOut variable.
.Cells(nextRow, "C").Value = myOut
Related
I have a some part of the codes of a macro it's working below changing of the cell value. But I want to replace them as linking a command button + getting data from a closed workbook. Can someone help me about re-edit them?
Thank you for help!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Chck As Integer, Cnt As Integer
Dim Save As String
Dim Subjt As Integer
If Not Intersect(Range("A1"), Target) Is Nothing And Not Target = "" Then
With Workbooks("Data2.xlsm").Worksheets("Datas")
Application.EnableEvents = False
Worksheets("Sheet1").Cells.Clear
For Chck = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
Select Case .Cells(Chck, "C")
Case "Number"
Subjt = Chck
Case ""
If Save <> "" Then
Save = "C" & Subjt & ":Q" & Subjt & Save
.Range(Save).Copy
Cnt = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
If Cnt > 1 Then Cnt = Cnt + 2
Worksheets("Sheet1").Range("A" & Cnt).PasteSpecial
Save = ""
End If
Case Target
If .Cells(Chck, "B") = "Number" Then Save = Save & ", C" & Chck & ":Q" & Chck
End Select
Next
Application.EnableEvents = True
End With
End If
End Sub
Try this in a regular module:
EDIT: made a few fixes
Sub CopyDataValues()
Dim Chck As Long, Cnt As Long
Dim Save As String
Dim Subjt As Long, valA1
Dim ws1 As Worksheet, wsData As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set wsData = Workbooks("Data2.xlsm").Worksheets("Datas")
Cnt = ws1.Range("A" & Rows.Count).End(xlUp).Row
Cnt = Cnt + 2
valA1 = ws1.Range("A1").Value
If Len(valA1) > 0 Then
With wsData
Application.EnableEvents = False
'ws1.Cells.Clear
For Chck = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
Select Case .Cells(Chck, "C")
Case "NUMBER"
Subjt = Chck
Case ""
If Save <> "" Then
Save = "C" & Subjt & ":Q" & Subjt & Save
.Range(Save).Copy ws1.Range("A" & Cnt)
Cnt = Cnt + 2
Save = ""
End If
Case valA1
If .Cells(Chck, "B") = "REAL" Then
Debug.Print "matched " & valA1 & " on row " & Chck
Save = Save & ", C" & Chck & ":Q" & Chck
End If
End Select
Next
Application.EnableEvents = True
End With
End If
End Sub
Change Private Sub to Sub only and assign the macro to your related button.
For the workbook first, you have to create an excel object to get the closed workbook in it.
the macro below takes two cell values (from first and second column)
and displays the column and there cell content in a Pop up Form
Im trying to add the condition that only the column and cell value is displayed if the cell contains value.
something like that =IF(A1<>"",result,"")
but I dont know how to implement that for all cells not only for a specific one.
Option Explicit
Const rangeForSearch = "G2"
Const rowTitles = 4
Dim arrTmp
Dim lastRow As Long, lastColumn As Long
Dim textForSearch As String, textForSearch_withoutSpaces As String
Dim strTmp As String
Dim i As Long, j As Long
Sub searchPerson()
Application.ScreenUpdating = False
With ActiveSheet
textForSearch = .Range(rangeForSearch)
If textForSearch = "" Then
MsgBox "Input text in cell """ & rangeForSearch & """ and try again!", vbCritical
Application.ScreenUpdating = True
Exit Sub
End If
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastColumn = .Cells(rowTitles, .Columns.Count).End(xlToLeft).Column
If lastRow <= rowTitles Or lastColumn <= 2 Then
MsgBox "Dataset is wrong! Check it and try again!", vbCritical
Application.ScreenUpdating = True
Exit Sub
End If
arrTmp = .Range(.Cells(rowTitles, "A"), .Cells(lastRow, lastColumn))
End With
'---------------------------------------
textForSearch_withoutSpaces = Replace(textForSearch, " ", "")
For i = LBound(arrTmp, 1) + 1 To UBound(arrTmp, 1)
strTmp = Replace(arrTmp(i, 1) & arrTmp(i, 2), " ", "")
If StrComp(textForSearch_withoutSpaces, strTmp, vbTextCompare) = 0 Then Exit For
Next i
If i = UBound(arrTmp, 1) + 1 Then
strTmp = textForSearch & vbCrLf & vbCrLf & "No dataset!"
Else
strTmp = textForSearch
For j = 3 To lastColumn
strTmp = strTmp & vbCrLf & vbCrLf & arrTmp(1, j) & ": " & arrTmp(i, j)
Next j
End If
Application.ScreenUpdating = True
MsgBox strTmp, , "Result"
End Sub
maybe
For j = 3 To lastColumn
If Not IsEmpty(arrTmp(i, j)) Then strTmp = strTmp & vbCrLf & vbCrLf & arrTmp(1, j) & ": " & arrTmp(i, j)
Next j
I would like to create Line charts (2-D Line with Markers) for a set of records.
Screenshot of Excel tab
(a) Every three rows represent a set to be charted. The fourth column, though it appears, need not be charted. In the screenshot there are 18 rows, which is six sets of records.
(b) One Line chart required for each set of records. Hence a total of six charts to be created automatically.
(c) Also, the charts are to be created in different Excel tabs. Three charts per tab, hence this should create two Excel tabs with three charts placed in each tab.
I have prepared some code for automatic charts generation using VBA macro in excel see if this helps.
Below code will generate charts for data available in excel:
Dim Startrow As String
Dim Lastrow As String
Dim Lastcolumn As String
Dim ws1 As String
Dim cs2 As String
Dim cs3 As String
Dim ws(100)
Dim count As String
Dim i As Integer
Sub Final()
For j = 2 To Sheets.count
count = Sheets.count
Sheet1.Activate
Cells(i, 1) = Sheets(i).Name
'ws(i) = Sheets(i).Name
'MsgBox Sheets.Count
'MsgBox count
'MsgBox ws(i)
Next
For i = 2 To count
MsgBox count
MsgBox i
Sheet1.Activate
ws(i) = Cells(i, 1)
Sheets(ws(i)).Activate
'Sheets(ws(i)).Activate
MsgBox ws(i)
'MsgBox Range("B1")
'MsgBox IsEmpty(Range("B2"))
If IsEmpty(Range("B1")) = False Then
Startrow = 2
'MsgBox Startrow
Lastrow = Cells(Rows.count, 1).End(xlUp).Row
'MsgBox Lastrow
Lastcolumn = Split(Columns(Range("A1").End(xlToRight).Column).Address(, False), ":")(1)
'MsgBox Lastcolumn
Call test1
MsgBox i
End If
Next
End Sub
Function test1()
Dim letter As String
Dim letter1 As String
Dim letter2 As String
Dim letter3 As String
Dim x As Integer
MsgBox ws(i)
x = Range(Lastcolumn & 1).Column
'MsgBox x
Dim cs As Worksheet
Set cs = ThisWorkbook.Sheets.Add
'ws.name = "PrivateBytes_000005_Charts"
'ws2 = "PrivateBytes_000005_Charts"
cs.Name = ws(i) + "_Charts"
'MsgBox ws.Name
cs2 = ws(i) + "_Charts"
MsgBox cs2
cs3 = ws(i)
MsgBox cs3
If x < 27 Then
For i = 2 To x
letter3 = Chr(64 + i)
'chart command
Sheets(cs2).Activate
ActiveSheet.Shapes.AddChart2(227, xlLineStacked).Select
ActiveChart.SetSourceData Source:=Sheets(cs3).Range("A" & Startrow & ":A" & Lastrow & "," & letter3 & Startrow & ":" & letter3 & Lastrow)
With ActiveChart
.HasTitle = True
Sheets(cs3).Activate
.ChartTitle.Text = Range(letter3 & "1").Value
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
End With
Next
End If
If x >= 27 Then
For i = 2 To 26
letter3 = Chr(64 + i)
'chart command
Sheets(cs2).Activate
ActiveSheet.Shapes.AddChart2(227, xlLineStacked).Select
ActiveChart.SetSourceData Source:=Sheets(cs3).Range("A" & Startrow & ":A" & Lastrow & "," & letter3 & Startrow & ":" & letter3 & Lastrow)
With ActiveChart
.HasTitle = True
Sheets(cs3).Activate
.ChartTitle.Text = Range(letter3 & "1").Value
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
End With
Next
For i = 27 To x
letter3 = Chr(Int((i - 1) / 26) + 64) & Chr(((i - 1) Mod 26) + 65)
'MsgBox letter3
'chart command
Sheets(cs2).Activate
ActiveSheet.Shapes.AddChart2(227, xlLineStacked).Select
ActiveChart.SetSourceData Source:=Sheets(cs3).Range("A" & Startrow & ":A" & Lastrow & "," & letter3 & Startrow & ":" & letter3 & Lastrow)
With ActiveChart
.HasTitle = True
Sheets(cs3).Activate
.ChartTitle.Text = Range(letter3 & "1").Value
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
End With
Next
End If
Sheets(cs.Name).Activate
ActiveChart.Parent.Name = "Test1"
Call AutoSpace_Shapes_Vertical
'Return
'Unload UserForm1
End Function
Function AutoSpace_Shapes_Vertical()
'Automatically space and align shapes
Sheets(cs2).Activate
ActiveSheet.ChartObjects("Test1").Activate
ActiveSheet.Shapes.SelectAll
Dim shp As Shape
Dim lCnt As Long
Dim dTop As Double
Dim dLeft As Double
Dim dHeight As Double
Const dSPACE As Double = 8
'Check if shapes are selected
If TypeName(Selection) = "Range" Then
MsgBox "Please select shapes before running the macro."
Exit Function
End If
'Set variables
lCnt = 1
'Loop through selected shapes (charts, slicers, timelines, etc.)
For Each shp In Selection.ShapeRange
With shp
'If not first shape then move it below previous shape and align left.
If lCnt > 1 Then
.Top = dTop + dHeight + dSPACE
.Left = dLeft
End If
'Store properties of shape for use in moving next shape in the collection.
dTop = .Top
dLeft = .Left
dHeight = .Height
End With
'Add to shape counter
lCnt = lCnt + 1
Next shp
End Function
'End Sub
'End Sub
enter image description here
I have some procedure where it takes different amount of time to execute. If I do nothing it takes 5 times longer to execute. When I click left mouse button during execution of same procedure, it finishes after few seconds. Can anyone explain why that happens and how to prevent it from happening in future?
I have tried to set arrays in code to nothing.
Sub Main()
Dim NumberOfCompanies As Long
Dim LastRow As Long
Dim StartTime As Double
Dim MinutesElapsed As String
StartTime = Timer
'////////////////////////////
Sheets("Process").Activate
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
...
Call Result
...
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Sheets("Result").Activate
'\\\\\\\\\\\\\\\\\\\\\\\\\\\
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
LastRow = CountRow("Result", 1)
NumberOfCompanies = Sheets("Result").Cells(LastRow, "A").Value
MsgBox "There are " & NumberOfCompanies & " candidates for Nace change!" & " This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
End Sub
Sub Result()
Dim CompanyNumbersArray As Variant
Dim StartingRow As Variant
Dim EndingRow As Variant
Dim LastRow As Long
Dim ArraySize As Long
Dim Count As Long
Dim i As Long
Dim j As Long
Dim CompanyRows As Long
Dim k As Long
Dim Background As Boolean
Dim CurrentCompany As String
Dim NextCompany As String
Dim Str As String
Sheets("Process").Activate
Sheets("Result").Range("A2:XFD1048576").Clear
Sheets("NoResult").Range("A2:XFD1048576").Clear
LastRow = CountRow("Process", 1)
CompanyNumbersArray = Sheets("Process").Range("A2:A" & LastRow)
StartingRow = Sheets("Process").Range("O2:O" & LastRow).Value
EndingRow = Sheets("Process").Range("P2:P" & LastRow).Value
Sheets("Process").Range("A2:S" & LastRow).Copy Destination:=Sheets("Result").Range("A2:S" & LastRow)
Sheets("Process").Range("A2:S" & LastRow).Copy Destination:=Sheets("NoResult").Range("A2:S" & LastRow)
Sheets("Result").Range("A:T").Borders(xlInsideHorizontal).LineStyle = xlLineStyleNone
Sheets("NoResult").Range("A:T").Borders(xlInsideHorizontal).LineStyle = xlLineStyleNone
ArraySize = UBound(CompanyNumbersArray)
Count = 1
For i = 1 To ArraySize - 1
CurrentCompany = CompanyNumbersArray(i, 1)
NextCompany = CompanyNumbersArray(i + 1, 1)
If CurrentCompany <> NextCompany Then
Count = Count + 1
End If
Next
Str = "Result: Copying data to sheets /Result/ and /NoResult/ "
Call ProgressOfCode(1, 4, Str)
i = 1
For j = 1 To Count
Background = True
CompanyRows = EndingRow(i, 1) - StartingRow(i, 1) + 1
For k = 0 To CompanyRows - 1
If (Sheets("Process").Range("R" & i + 1 + k).Interior.ColorIndex = xlNone) Then
Background = False
Else
Background = True
Exit For
End If
Next
If Background = False Then
Sheets("Result").Range("A" & StartingRow(i, 1) & ":T" & EndingRow(i, 1)).Value = vbNullString
Sheets("Result").Range("A" & StartingRow(i, 1) & ":T" & EndingRow(i, 1)).Interior.Color = xlNone
ElseIf Background = True Then
Sheets("NoResult").Range("A" & StartingRow(i, 1) & ":T" & EndingRow(i, 1)).Value = vbNullString
Sheets("NoResult").Range("A" & StartingRow(i, 1) & ":T" & EndingRow(i, 1)).Interior.Color = xlNone
End If
If EndingRow(i, 1) < LastRow Then
i = EndingRow(i, 1)
End If
Next
Str = "Result: Copying data to sheets /Result/ and /NoResult/ "
Call ProgressOfCode(2, 4, Str)
Sheets("Result").Activate
Sheets("Result").Range("A:T").Sort Key1:=Range("N2"), key2:=Range("A2"), Order1:=xlAscending, Order2:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
Sheets("NoResult").Activate
Sheets("NoResult").Activate
Sheets("NoResult").Range("A:T").Sort Key1:=Range("N2"), key2:=Range("A2"), Order1:=xlAscending, Order2:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
Call ResultRestoreLines("Result")
Str = "Result: Copying data to sheets /Result/ and /NoResult/ "
Call ProgressOfCode(3, 4, Str)
Call ResultRestoreLines("NoResult")
Str = "Result: Copying data to sheets /Result/ and /NoResult/ "
Call ProgressOfCode(4, 4, Str)
Application.StatusBar = "Done!"
Application.Wait (Now + TimeValue("00:00:01"))
Application.StatusBar = False
End Sub
Private Sub ResultRestoreLines(SheetName As String)
Dim CompanyNumbersArray As Variant
Dim CompanyStructureArray As Variant
Dim LastRow As Long
Dim ArraySize As Long
Dim Count As Long
Dim i As Long
Dim CurrentRow As Long
Dim CurrentCompany As String
Dim NextCompany As String
LastRow = CountRow(SheetName, 1)
CompanyNumbersArray = Sheets(SheetName).Range("A2:A" & LastRow).Value
CompanyStructureArray = Sheets(SheetName).Range("N2:N" & LastRow).Value
ArraySize = UBound(CompanyNumbersArray)
Count = 1
For i = 1 To ArraySize - 1
CurrentCompany = CompanyNumbersArray(i, 1)
NextCompany = CompanyNumbersArray(i + 1, 1)
If CurrentCompany <> NextCompany Then
Count = Count + 1
End If
Next
CurrentRow = 2
For i = 1 To Count
Sheets(SheetName).Range("A" & CurrentRow & ":P" & CurrentRow + CompanyStructureArray(CurrentRow - 1, 1) - 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
CurrentRow = CurrentRow + CompanyStructureArray(CurrentRow - 1, 1)
Next
LastRow = CountRow(SheetName, 1)
Sheets(SheetName).Cells(LastRow + 2, "A").Value = Count
End Sub
I would expect same code to run same amount of time.
This very simple macro is taking 93 seconds just run through 55 iterations. I also tried it as a for next loop, same result.
Dim thedate As Date
Dim current_cell As Long
Dim f As Single
f = Timer()
current_cell = Range("e65000").End(xlUp).Row
thedate = Range("e" & current_cell).Value
Dim i As Integer
Application.ScreenUpdating = False
Do Until Range("f" & current_cell).Value = ""
i = i + 1
If i = 900 Then
End
End If
If Range("g" & current_cell).Value <> "x" Then
Cells(current_cell, "e").Value = thedate
Else
thedate = thedate + 1
Cells(current_cell, "e").Value = thedate
End If
current_cell = current_cell + 1
Loop
Application.ScreenUpdating = True
MsgBox "ET: " & Format(Timer - f, "0.000") & "s"
FIRST UPDATE
Ok, I looked at another page and they recommended using the with feature. I did that and it still took me 28 seconds to loop through 15 cells.
Dim thedate As Date
Dim current_cell As Long
Dim f As Single
f = Timer()
current_cell = Range("e65000").End(xlUp).Row
Dim stop_working As Long
stop_working = Range("f65000").End(xlUp).Row - 1
thedate = Range("e" & current_cell).Value
Dim i As Integer
Application.ScreenUpdating = False
With Sheets("time")
For k = current_cell To stop_working
i = i + 1
If i = 900 Then
End
End If
If .Range("g" & current_cell).Value <> "x" Then
.Cells(current_cell, "e").Value = thedate
Else
thedate = thedate + 1
.Cells(current_cell, "e").Value = thedate
End If
current_cell = current_cell + 1
Next
End With
Application.ScreenUpdating = True
MsgBox "ET: " & Format(Timer - f, "0.000") & "s"
THIRD UPDATE
Ok, I've done some research and I learned that you're not supposed to loop over ranges and that you're supposed to put the ranges in an array. I don't really understand this but I did try putting the cells into an array and using the for each feature. It still seems like I'm looping over ranges because whenever a step into the function it still noticeably takes a very long time to cross over the rng part of the code. My second problem is that none of the values are getting published on the screen. My third problem is that I'm getting a type mismatch with thedate. My fourth problem is that I don't understand the difference betwene value and value2.
Sub dates()
Dim thedate
Dim current_cell As Long
Dim f As Single
f = Timer()
Dim rng As Range, rng2 As Range
current_cell = Range("e65000").End(xlUp).Row
Dim done As Long
done = Range("f65000").End(xlUp).Row - 1
Set rng = Range("g" & current_cell, "g" & done)
Set rng2 = Range("e" & current_cell, "e" & done)
thedate = Format(thedate, Date)
thedate = rng2.Value
'thedate = rng2.Value
Dim i As Integer
i = 7
'Application.ScreenUpdating = False
'With Sheets("time")
For Each cell In rng
If cell.Value <> "x" Then
rng2.Value = thedate
Else
thedate = thedate + 1
rng2.Value = thedate
End If
Next
'End With
'Application.ScreenUpdating = True
MsgBox "ET: " & Format(Timer - f, "0.000") & "s"
4TH UPDATE
I have a new code that works but it still take 78 seconds to run through 50 iterations. Don't understand what the problem is.
Dim iRow As Long, erow As Long
erow = Cells(Rows.Count, "e").End(xlUp).Row
Dim thedate As Date
Dim f As Single
f = Timer()
For iRow = erow To 35856
If Cells(iRow, "G") = "x" Then
Cells(iRow, "E").Value = Cells(iRow - 1, "E").Value + 1
Else
Cells(iRow, "E").Value = Cells(iRow - 1, "E").Value
End If
Next iRow
MsgBox "ET: " & Format(Timer - f, "0.000") & "s"
End Sub
Problem solved. I need to change calculation to manual and disable the firing of events.
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
For iRow = 3 To Cells(Rows.Count, "G").End(xlUp).Row
If Cells(iRow, "G") = "x" Then
Cells(iRow, "E").Value = Cells(iRow - 1, "E").Value + 1
Else
Cells(iRow, "E").Value = Cells(iRow - 1, "E").Value
End If
Next iRow
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True