I'am trying to replace . to / on selection but after replace some cell not change. I have to change it mannual by click enter. Please suggest it via VBA. for change. I also try to calculate and numberformat but both are not working
Sub Reverse_Cheque()
Dim ChequeDate As String, i As Long
i = 2
'Debug.Print ChequeDate.Address
Range("A1").CurrentRegion.Columns.AutoFit
Range("L:L").Insert
Range("L1").Value = "expire date"
Do Until Range("k" & i).Value = ""
ChequeDate = Range("K" & i).Value
Range("k" & i).Value = Replace(Range("k" & i).Value, ".", "/")
Range("k" & i).NumberFormat = "dd-mm-yyy"
'Range("L" & i).Value = Range("k" & i).Value + 89
i = i + 1
Loop
End Sub
Range("k" & i).Value = Replace(Range("k" & i).Value, ".", "/")
Range("k" & i).NumberFormat = "dd-mm-yyy"
This is not the right way to do it. This will only work if the previous number format is "General". This is an example to replicate the above issue. The below will not work.
[A1].NumberFormat = "#"
[A1].Value = #1/1/2021#
[A1].NumberFormat = "dd/mm/yyyy"
For the above to work, you will have to press F2 and then Enter.
The below will work without F2 and Enter
[A1].NumberFormat = "General"
[A1].Value = #1/1/2021#
[A1].NumberFormat = "dd/mm/yyyy"
And hence it is always advisable to change the number format first before inputing new data.
Also you do not need a loop. You can use .Replace to replace all . in one go. Here is an example. Change it to suit your needs.
With Columns("K")
.NumberFormat = "dd/mm/yyyy"
.Replace What:=".", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End With
Related
I recorded a macro, which I want to modify in order to use it automatically in multiple ranges in the Excel worksheet. Here's the code:
Sub Macro1()
For i = 6 To 22370 Step 5
ActiveWorkbook.SaveAs Filename:= _
"tute.xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Rows(i:i).Select
Range("D" & i).Activate
Selection.Insert Shift:=xlDown
Range("D" & i).Select
ActiveCell.FormulaR1C1 = "xyz"
Range("A"&"i-1":"C"&"i-1").Select
Selection.Copy
Range("A" & i).Select
ActiveSheet.Paste
Range("E" & i).Select
Application.CutCopyMode = False
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=R[-1]C*R[4]C"
Range("E" & i).Select
Selection.AutoFill Destination:=Range("E37:AO37"), Type:=xlFillDefault
Range("E"&i:"AO"&i).Select
Range("D" & i).Select
Next
End Sub
I would like to use the variable "i" to call specific rows, as in the case of Rows(i:i).Select or a range such as Range("E"&i:"AO"&i).Select, but I get an error message: "Expected: list separator or )"
Can you help pls?
Thank you in advance
Besides my comments above, here's a quick rewrite to get rid of all of the superfluous .Activate and .Select lines. Those are for humans, VBA doesn't need to select something before acting on it. It can just act on it directly.
Sub Macro1()
'This line shouldn't be in your for loop otherwise you save this workbook like 4000 times
ActiveWorkbook.SaveAs Filename:="tute.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
For i = 6 To 22370 Step 5
'No reason to select the row since we just go ahead and activate a particular cell immediately afterwords
'Rows(i:i).Select
'No reason to "Activate" the cell. We can just shift it down without highlighting the thing for the user
'Range("D" & i).Activate
Range("D" & i).Insert Shift:=xlDown
'No need to .Select. Just change the formula directly.
'Range("D" & i).Select
Range("D" & i).FormulaR1C1 = "xyz"
'Again, no need to .Select. And we can do the copy/paste in one line
'Range("A"&"i-1":"C"&"i-1").Select
'Selection.Copy
'Range("A" & i).Select
'ActiveSheet.Paste
Range("A" & i-1 & ":C" & i-1).Copy Destination:=Range("A" & i)
'Removing superfluous select again
'Range("E" & i).Select
'Also superfluous code that isn't needed
'Application.CutCopyMode = False
'Application.CutCopyMode = False
Range("E" & i).FormulaR1C1 = "=R[-1]C*R[4]C"
'Range("E" & i).Select
Range("E" & i).AutoFill Destination:=Range("E37:AO37"), Type:=xlFillDefault
'Superfluous selects
'Range("E"&i:"AO"&i).Select
'Range("D" & i).Select
Next
End Sub
And then cleaned up to remove all of that:
Sub Macro1()
ActiveWorkbook.SaveAs Filename:="tute.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
For i = 6 To 22370 Step 5
'Shift column D for this line down a row (add a new empty cell for this line)
Range("D" & i).Insert Shift:=xlDown
'Change the value to xyz of column D for this line (the new cell)
Range("D" & i).FormulaR1C1 = "xyz"
'Copy three lines in column A:C and paste 1 line down
Range("A" & i-1 & ":C" & i-1).Copy Destination:=Range("A" & i)
'Change the formula in column E for this line
Range("E" & i).FormulaR1C1 = "=R[-1]C*R[4]C"
'Not sure if this is what you are actually after here. Perhaps that should be `Range("E" & i & ":AO" & i)?`
Range("E" & i).AutoFill Destination:=Range("E37:AO37"), Type:=xlFillDefault
Next
End Sub
I am having problems with my code. I am trying to inset values into a "database" by using the find function to identify the correct rownumber. when i run the code the find function returns the next rownumber ie. the serchname is in row 300 but the data is inserted in row 301.
the code i am using is as follows:
For Each Cell In Workbooks(controlfile).Sheets("Lab").Range("B9:B56")
If Cell.Value <> "" Then
'Range("N" & latestRow).Value = Right(DataArray(1), 4) & Right(DataArray(2), 4)
'Range("N" & latestRow).NumberFormat = "00000000"
søgeOrd = Right(Cell.Value, 4) & Right(Cell.Offset(0, 1), 4)
Workbooks(controlfile).Sheets("Lab").Range("A1").Value = søgeOrd
Workbooks(controlfile).Sheets("Lab").Range("A1").NumberFormat = "00000000"
LinjeL = Cell.Row
FGM = Workbooks(controlfile).Sheets("Lab").Range("F" & LinjeL).Value
STA = Workbooks(controlfile).Sheets("Lab").Range("I" & LinjeL).Value
BMK = Workbooks(controlfile).Sheets("Lab").Range("J" & LinjeL).Value
VK = Workbooks(controlfile).Sheets("Lab").Range("L" & LinjeL).Value
DP = Workbooks(controlfile).Sheets("Lab").Range("M" & LinjeL).Value
SNB = Workbooks(controlfile).Sheets("Lab").Range("N" & LinjeL).Value
Workbooks(controlfile).Sheets("Lab").Range("A1").ClearContents
'find søgeord i database og indsæt de værdier som er fundet i lab
Workbooks(FileName).Sheets("Database").Activate
Columns("N:N").Select
Set cellD = Selection.Find(What:=Workbooks(controlfile).Sheets("Lab").Range("A1").Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not cellD Is Nothing Then LinjeD = cellD.Row
If Range("E" & LinjeD).Value <> "" Then
'kopier alle data til fejllog hvis der allerede er data
Range("A" & LinjeD).Select
ActiveCell.EntireRow.Copy
Workbooks(FileName).Worksheets("Fejllog").Activate
LastLine = Workbooks(FileName).Sheets("Fejllog").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
Range("A" & LastLine).PasteSpecial
Application.CutCopyMode = False
Workbooks(FileName).Sheets("Database").Activate
Range("E" & LinjeD).Value = FGM
Range("H" & LinjeD).Value = STA
Range("I" & LinjeD).Value = BMK
Range("O" & LinjeD).Value = Format(Now, "dd.mm.yyyy")
Range("P" & LinjeD).Value = VK
Range("Q" & LinjeD).Value = DP
Range("R" & LinjeD).Value = SNB
Workbooks(controlfile).Sheets("Lab").Activate
Else
Range("E" & LinjeD).Value = FGM
Range("H" & LinjeD).Value = STA
Range("I" & LinjeD).Value = BMK
Range("O" & LinjeD).Value = Format(Now, "dd.mm.yyyy")
Range("P" & LinjeD).Value = VK
Range("Q" & LinjeD).Value = DP
Range("R" & LinjeD).Value = SNB
Workbooks(controlfile).Sheets("Lab").Activate
End If
End If
Next Cell
Any input would be greatly appreciated, thank you.
I re-wrote your code to eliminate use of the Selection object.
Private Sub Snippet()
Dim WsDb As Worksheet
Dim ClmN As Range
Dim cellID As Range
Dim What As Variant
Dim LineID As Long
What = Workbooks(controlfile).Sheets("Lab").Range("A1").Value
Set WsDb = Workbooks(Filename).Sheets("Database")
Set ClmN = WsDb.Columns("N:N")
Set cellD = ClmN.Find(What:=What, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not cellD Is Nothing Then LinjeD = cellD.Row
End Sub
Observe how the definition of the worksheet on which you do your search is now done by declaring a variable for it. The code will now work smoothly in the background without screen flickering.
Now you can blame me for destroying your reference to the ActiveCell. Did I really? Which cell was active in your code when the Database tab was activated? Could have been anyone or none. Now the code will crash because the ActiveCell isn't in the ClmN range. Obviously, you need to specify a cell in that range for starting the search.
Does the cellID range start in a row other than where What was found? I doubt it and you don't claim so, either. You say that a row gets inserted at a point other than LineID. That is normal and has to do with the action of inserting a row, not related to the code you published. Logically, the new row should take the place of the one you specified. Therefore the cellId.Row would now be one row lower than before. However, I got this wrong many times. Therefore I always test which row is the old and which one the new. It's not difficult - and it's always the same.
I have found the solution.
I had mistakenly cleared the content of the cell used as the search name before the search began. this resulted in a search for an empty cell.
Thank you to all of you for making inputs, and helping me clean up my code :)
It is amazing how you can spend hours looking at something, only to find the answer is right in front of you.
I would like to copy and paste a formula from column P to column C using a loop in VBA. The code should only copy and paste for numeric values in column P and do nothing when cell is blank.
Sub TestAll()
For i = 10 To 91
Worksheets("Hello").Range("P" & i).Formula = "=" & "MRound(" & Range("C" &
i).Value & "+$C$7" & ",0.125)"
Next i
Application.CutCopyMode = False
Range("P10:P91").Select
Selection.Copy
Range("C10").Select
Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End Sub
Since you're already using a for loop, you can directly copy the data there.
To check if it's a numeric data, you can use the IsNumeric( Expression ) function and the code could be something like this:
Sub TestAll()
For i = 10 To 91
Worksheets("Hello").Range("P" & i).Formula = "=" & "MRound(" & Range("C" & i).Value & "+$C$7" & ",0.125)"
If (IsNumeric(Worksheets("Hello").Range("P" & i).Value)) Then
Worksheets("Hello").Range("C" & i).Value = Worksheets("Hello").Range("P" & i).Value
End If
Next i
End Sub
Note: Please note that this check is redundant, since the formula
will give you always the same result over and over.
Hope this help.
Sub TestAll()
For i = 10 To 91
If (IsEmpty(Worksheets("Hello").Range("C" & i).Value))
Then
Worksheets("Hello").Range("P" & i).Value = ""
ElseIf (IsNumeric(Worksheets("Hello").Range("C" &
i).Value)) Then
Worksheets("Hello").Range("P" & i).Formula = "=" &
"MRound(" & Range("C" & i).Value & "+$C$7" & ",0.125)"
Else
Worksheets("Hello").Range("P" & i).Value =
"CALIBRATED"
End If
Next i
Application.CutCopyMode = False
Range("P10:P91").Select
Selection.Copy
Range("C10").Select
Selection.PasteSpecial
Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End Sub
I have an sheet with over 1000 rows. In column A I have a text like
:IO.Tgr37.Tank37.TT
In sheet "innstiilinger" in column F, I have a bunch of keywords to look for,
like Tgr37 on row7 and Tgr10 on row8
In column G I have
Tgr 120, Tgr 600.......
If the text has Tgr37 or Tgr10 in it I would like to add a prefix to the text.
If the text has Tgr120 or Tgr600 in it I would add another prefix to the text..
I tried this code:
Dim sCellVal As String
sCellVal = Range("A" & ActiveCell.Row).Value
Dim FindString As String
Dim Rng As Range
FindString = sCellVal
If Trim(FindString) <> "" Then
With Sheets("Innstillinger").Range("F:F") 'searches all of column F
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
tag_opc.Value = Sheets("Innstillinger").Range("F6") & Range("A" & ActiveCell.Row).Value & ".Value" 'value found
Else
MsgBox "Nothing found" 'value not found
End If
End With
End If
but it do not work, when I put my keyword in column A and the text in column F in sheet "innstillinger" it works.
Sorry for my bad English but I hope you understand my problem...
Excel 2013
Where are you declaring the tag_opc object?
Anyway, the .Find method is a poor choice to use for operations like this. The most efficient way to perform what you're doing is to lift your data into an array (or arrays), process what you need to process, then transpose the results back to where they need to go.
To make things a little easier to follow, though, I'll suggest an option B, which is to use a For Each loop over the range in question instead.
Dim sCellVal As String
Dim wsReference As Excel.Worksheet
Set wsReference = Worksheets(1) 'or refer to this by name
sCellVal = wsReference.Range("A" & ActiveCell.Row).Value
Dim wsSearch As Excel.Worksheet
Dim rng As Range, cell As Range
Set wsSearch = Worksheets(2) 'or refer to this by name
Set rng = wsSearch.Range("F:F")
If Trim(Len(sCellVal)) <> 0 Then
For Each cell In rng
'Perform actions
Next cell
End If
This should cover the core of what you would need to do. However, I would swap out the ActiveCell for a more specific reference, since anything active in VBA is notoriously finicky. You can use a loop, for example, to increment an i value upward through each iteration.
Its a little ambiguous as to what you want to do here, though. You refer to "text" multiple times, but don't clarify which "text" you're referring to.
Can you provide Before and After examples? We'll probably be able to provide a better answer if we can see specifically what you're looking to do.
I have tried all sorts of trick today, i was close,but no... I have deleted all and got back to start. This is my code:
Private Sub UserForm_Initialize()
'Autofyll userform
nr = Sheets("Innstillinger").Range("D8")
tag_opc.Value = Range("A" & ActiveCell.Row).Value
unit.Value = Range("G" & ActiveCell.Row).Value
min.Value = Range("F" & ActiveCell.Row).Value
max.Value = Range("E" & ActiveCell.Row).Value
io.Value = Range("D" & ActiveCell.Row).Value
ioType = Range("B" & ActiveCell.Row).Value
tagnavn = Range("C" & ActiveCell.Row).Value
Register = Range("L" & ActiveCell.Row).Value
test2 = Sheets("Innstillinger").Range("F9").Value
If Register = "registrert" Then
MsgBox "Denne er allerede registrert", vbExclamation, "kritisk feil"
Unload Me
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop
Tagimport.Show
End
End If
'Autofullfør Prefix og Suffix til tag
Dim sCellVal As String
sCellVal = Range("A" & ActiveCell.Row).Value
If sCellVal Like "*Tgr10*" Or _
sCellVal Like "*Tgr15*" Or _
sCellVal Like "*Tgr17*" Or _
sCellVal Like "*Tgr37*" Or _
sCellVal Like "*Tgr40x*" Or _
sCellVal Like "*Tgr70x*" Or _
sCellVal Like "*Tgr85*" Or _
sCellVal Like "*Tgr90*" Or _
sCellVal Like "*Tgr91*" Or _
sCellVal Like "*Tgr100*" Or _
sCellVal Like "*Tgr104*" Or _
sCellVal Like "*Tgr105*" Or _
sCellVal Like "*Tgr110*" Or _
sCellVal Like "*Tgr115*" Or _
sCellVal Like "*Tgr118*" Or _
sCellVal Like "*Tgr120x*" Or _
sCellVal Like "*Tgr128x*" Or _
sCellVal Like "*Tgr135*" Or _
sCellVal Like "*Tgr176*" Or _
sCellVal Like "*Tgr180x*" Or _
sCellVal Like "*TgrROx*" Or _
sCellVal Like "*Past1*" Or _
sCellVal Like "*Past3*" Or _
sCellVal Like "*Past4x*" Or _
sCellVal Like "*Past5*" Then
tag_opc.Value = Sheets("Innstillinger").Range("F6") & Range("A" & ActiveCell.Row).Value & ".Value" 'String henta ifrå innstillinger F6
ElseIf sCellVal Like "*Past6x*" Or _
sCellVal Like "*Past7*" Or _
sCellVal Like "*Past904*" Or _
sCellVal Like "*MMS*" Or _
sCellVal Like "*Servicex*" Or _
sCellVal Like "*Tgr900*" Or _
sCellVal Like "*Tgr910*" Or _
sCellVal Like "*Tgr915*" Or _
sCellVal Like "*Tgr920*" Or _
sCellVal Like "*L952LIS*" Or _
sCellVal Like "*L952M2*" Or _
sCellVal Like "*T172BTU1*" Or _
sCellVal Like "*T172BFT1*" Or _
sCellVal Like "*T172Bph1*" Or _
sCellVal Like "*T172BTT1*" Or _
sCellVal Like "*Myse*" Or _
sCellVal Like "*Motorhead*" Then
tag_opc.Value = Sheets("Innstillinger").Range("G6") & Range("A" & ActiveCell.Row).Value & ".Value" 'String henta ifrå innstillinger G6
ElseIf sCellVal Like "*Tgr170*" Or _
sCellVal Like "*Tgr171*" Or _
sCellVal Like "*Tgr173*" Then
tag_opc.Value = Sheets("Innstillinger").Range("H6") & Range("A" & ActiveCell.Row).Value & ".Value" 'String henta ifrå innstillinger H6
ElseIf sCellVal Like "*Pasteur1*" Or _
sCellVal Like "*Pasteur2*" Or _
sCellVal Like "*Pasteur3*" Or _
sCellVal Like "*Pasteur4*" Or _
sCellVal Like "*Pasteur15*" Or _
sCellVal Like "*SmørSmelter*" Or _
sCellVal Like "*EksterneSystem*" Or _
sCellVal Like "*Trykk_Isvann*" Or _
sCellVal Like "*Trykk_Luft*" Or _
sCellVal Like "*Vannmåler*" Then
tag_opc.Value = "OPC::Text3:" & Range("A" & ActiveCell.Row).Value & ".Value"
ElseIf sCellVal Like "*Pasteur11*" Or _
sCellVal Like "*Pasteur12*" Or _
sCellVal Like "*Tgr65*" Or _
sCellVal Like "*Tgr70*" Or _
sCellVal Like "*Tgr75*" Or _
sCellVal Like "*Tgr145*" Or _
sCellVal Like "*Tgr166*" Or _
sCellVal Like "*Tgr180*" Or _
sCellVal Like "*Tgr211*" Or _
sCellVal Like "*Tgr244*" Or _
sCellVal Like "*TgrRO*" Or _
sCellVal Like "*Inndamper*" Or _
sCellVal Like "*T167*" Or _
sCellVal Like "*Nivå_BT_Tapp2*" Or _
sCellVal Like "FilterElveVannFeil*" Then
tag_opc.Value = "OPC::Text4:" & Range("A" & ActiveCell.Row).Value & ".Value"
ElseIf sCellVal Like "*Tgr20*" Or _
sCellVal Like "*Tgr25*" Or _
sCellVal Like "*Tgr28*" Or _
sCellVal Like "*Tgr150*" Then
tag_opc.Value = "OPC::Text5:" & Range("A" & ActiveCell.Row).Value & ".Value"
Else
MsgBox "Finner ingen plassering" 'Kan ikkje plassere i program
End If
' Next cell
'fyll inn dropdownliste engineering unit
With unit
.AddItem "g/cm3"
.AddItem "µS/cm"
.AddItem "liter"
.AddItem "%"
.AddItem "m³/t"
.AddItem "l/t"
.AddItem "°C"
.AddItem "mBar"
.AddItem "Bar"
.AddItem "Ph"
.AddItem "ms"
.AddItem "m³"
End With
'Sjekker om det er analog eller digital logging
If ioType = "AnalogSignalIn" Then
Analog.Value = True
ElseIf ioType = "analogsignalIn" Then
Analog.Value = True
ElseIf ioType = "analogsignalin" Then
Analog.Value = True
ElseIf ioType = "Analogsignalin" Then
Analog.Value = True
ElseIf ioType = "AnalogSignalOut" Then
Analog.Value = True
ElseIf ioType = "analogsignalout" Then
Analog.Value = True
ElseIf ioType = "AnalogSignalout" Then
Analog.Value = True
ElseIf ioType = "BooleanSignal" Then
Digital.Value = True
ElseIf ioType = "booleansignal" Then
Digital.Value = True
ElseIf ioType = "booleanSignal" Then
Digital.Value = True
Else
MsgBox "Det må velges analog eller digitalt signal", vbExclamation, "kritisk feil"
End If
'Sett markør i Tagnamn hvis denne er tom
If tagnavn = "" Then
tagnavn.SetFocus
End If
End Sub
Private Sub Reg_Click()
'
If tagnavn.Value = "" Then
MsgBox "Denne har ingen TAG", vbExlamation, "dette går ikkje"
tagnavn.SetFocus
Exit Sub
End If
'Aktiver data-arket
'Velge kor data skal plasserast, analog eller digital
If Analog = True Then
If unit.Value = "" Then
MsgBox "Dette er ein analog verdi, vennligst velg ein måleenhet", vbExlamation, "dette går ikkje"
unit.SetFocus
Exit Sub
End If
Sheets(2).Activate
Range("A3").EntireRow.Insert
Active_Row = 3
'Fylle inn i kolonner
Range("A" & Active_Row) = meierinr + "_" + tagnavn '(AnalogTag)TagName"
Range("B" & Active_Row) = beskrivelse 'Description
Range("C" & Active_Row) = Sheets("Innstillinger").Range("D9") 'IOServerComputerName
Range("D" & Active_Row) = Sheets("Innstillinger").Range("D10") 'IOServerAppName
Range("E" & Active_Row) = Sheets("Innstillinger").Range("D11") 'TopicName
Range("F" & Active_Row) = tag_opc.Value 'ItemName
Range("G" & Active_Row) = Sheets("Innstillinger").Range("D12") 'AcquisitionType
Range("H" & Active_Row) = Sheets("Innstillinger").Range("D13") 'StorageType
Range("I" & Active_Row) = Sheets("Innstillinger").Range("D14") 'AcquisitionRate
Range("J" & Active_Row) = Sheets("Innstillinger").Range("D14") 'StorageRate
Range("K" & Active_Row) = Sheets("Innstillinger").Range("D15") 'TimeDeadband
Range("L" & Active_Row) = Sheets("Innstillinger").Range("D16") 'SamplesInAI
Range("M" & Active_Row) = Sheets("Innstillinger").Range("D17") 'AIMode
Range("N" & Active_Row) = Sheets("Innstillinger").Range("D18") 'EngUnits
Range("O" & Active_Row) = min 'MinEU
Range("P" & Active_Row) = max 'MaxEU
Range("Q" & Active_Row) = Sheets("Innstillinger").Range("D19") 'MinRaw
Range("R" & Active_Row) = Sheets("Innstillinger").Range("D20") 'MaxRaw
Range("S" & Active_Row) = Sheets("Innstillinger").Range("D21") 'Scaling
Range("T" & Active_Row) = Sheets("Innstillinger").Range("D22") 'RawType
Range("U" & Active_Row) = Sheets("Innstillinger").Range("D23") 'IntegerSize
Range("V" & Active_Row) = Sheets("Innstillinger").Range("D24") 'Sign
Range("W" & Active_Row) = Sheets("Innstillinger").Range("D25") 'ValueDeadband
Range("X" & Active_Row) = Sheets("Innstillinger").Range("D26") 'InitialValue
Range("Y" & Active_Row) = Sheets("Innstillinger").Range("D27") 'CurrentEditor
Range("Z" & Active_Row) = Sheets("Innstillinger").Range("D28") 'RateDeadband
Range("AA" & Active_Row) = Sheets("Innstillinger").Range("D29") 'InterpolationType
Range("AB" & Active_Row) = Sheets("Innstillinger").Range("D30") 'RolloverValue
Range("AC" & Active_Row) = Sheets("Innstillinger").Range("D31") 'ServerTimeStamp
Range("AD" & Active_Row) = Sheets("Innstillinger").Range("D32") 'DeadbandType
Range("AE" & Active_Row) = Sheets("Innstillinger").Range("D33") 'TagId
Range("AF" & Active_Row) = Sheets("Innstillinger").Range("D34") 'ChannelStatus
Range("AG" & Active_Row) = Sheets("Innstillinger").Range("D35") 'AITag
Range("AH" & Active_Row) = Sheets("Innstillinger").Range("D36") 'AIHistory
ElseIf Digital = True Then
Sheets(2).Activate
Active_Row = Range("A" & Rows.Count).End(xlUp).Row + 1
'Fylle inn i kolonner
Range("A" & Active_Row) = meierinr + "_" + tagnavn ':(DiscreteTag)TagName
Range("B" & Active_Row) = beskrivelse 'Description
Range("C" & Active_Row) = Sheets("Innstillinger").Range("D9") 'IOServerComputerName
Range("D" & Active_Row) = Sheets("Innstillinger").Range("D10") 'IOServerAppName
Range("E" & Active_Row) = Sheets("Innstillinger").Range("D11") 'TopicName
Range("F" & Active_Row) = tag_opc.Value 'ItemName
Range("G" & Active_Row) = Sheets("Innstillinger").Range("D12") 'AcquisitionType
Range("H" & Active_Row) = Sheets("Innstillinger").Range("D13") 'StorageType
Range("I" & Active_Row) = Sheets("Innstillinger").Range("D14") 'AcquisitionRate
Range("J" & Active_Row) = Sheets("Innstillinger").Range("D15") 'TimeDeadband
Range("K" & Active_Row) = Sheets("Innstillinger").Range("D16") 'SamplesInAI
Range("L" & Active_Row) = Sheets("Innstillinger").Range("D17") 'AIMode
Range("M" & Active_Row) = "0" 'Message0
Range("N" & Active_Row) = "1" 'Message1
Range("O" & Active_Row) = Sheets("Innstillinger").Range("D26") 'InitialValue
Range("P" & Active_Row) = Sheets("Innstillinger").Range("D27") 'CurrentEditor
Range("Q" & Active_Row) = Sheets("Innstillinger").Range("D31") 'ServerTimeStamp
Range("R" & Active_Row) = Sheets("Innstillinger").Range("D33") 'TagId
Range("S" & Active_Row) = Sheets("Innstillinger").Range("D34") 'ChannelStatus
Range("T" & Active_Row) = Sheets("Innstillinger").Range("D35") 'AITag
Range("U" & Active_Row) = Sheets("Innstillinger").Range("D36") 'AIHistory
Else
MsgBox "Her har du ikkje følgt med, det må velges analogt eller digitalt signal!!!", vbExclamation, "GAPELESTE"
Analog.SetFocus
End
End If
Sheets(1).Activate
'ActiveCell.Markere Tag som registrert.
Range("L" & ActiveCell.Row) = "registrert"
'oppdaterer regnearket
ActiveWorkbook.RefreshAll
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop
Unload Me
Tagimport.Show
End Sub
Private Sub Neste_Click()
Unload Me
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop
Tagimport.Show
End Sub
Private Sub Avbryt_Click()
Unload Me
End Sub
I want to get the part where i am listing up the different text to search for out on the sheet, not in the code.
The before is like this: IO.Tgr10.F182PT1
After should be like this: OPC::Text2:IO.Tgr10.F182PT1.Value
If before is like this: IO.Tgr150.F152PT1
After should be like this : OPC::Text5:IO.Tgr150.F152PT1.Value
I have an excel file full of adresses which I need to import in our system.
the housenumber column is formatted like this:
Normal house numbers just show the number but house numbers with a certain boxnumber are shown like this: 25 B12
I need to get the boxnumbers (if they exist) in another column
I managed to do this with these functions
Function GetBus(Text As String, ByRef NumberCell As Range) As String
Dim LastWord As String
LastWord = ReturnLastWord(Text)
If Left(LastWord, 1) = "B" Then
GetBus = Right(LastWord, Len(LastWord) - 1)
Else
GetBus = ""
End If
End Function
Function ReturnLastWord(Text As String) As String
Dim LastWord As String
LastWord = StrReverse(Text)
LastWord = Left(LastWord, InStr(1, LastWord, " ", vbTextCompare))
ReturnLastWord = StrReverse(Trim(LastWord))
End Function
So creating the new column with the box values is working. What is not working is deleting the box part in the number column (fe: if number value is 25 B1 the B1 part should be removed)
Any Ideas of how to do this or is this not possible in excel?
This is something which I wrote couple of years ago so I am not sure if there are bugs in it but a quick test seems to portray that it is working correctly. You might have to change it to make it exactly work in your situation.
Code:
Option Explicit
Sub SplitAddress()
Dim MyAr() As String, tempStr As String, strUnique As String
Dim lRow As Long, i As Long, j As Long, lRow2 As Long
Dim cell As Range
strUnique = "SiddR" & Format(Now, "ddmmyyhhmmss")
With ActiveSheet
.Columns("A:A").Replace What:=" ", Replacement:=strUnique, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns("C").NumberFormat = "#"
.Columns("D").NumberFormat = "#"
For i = 2 To lRow
MyAr = Split(.Range("A" & i).Value, strUnique)
tempStr = ""
For j = LBound(MyAr) To (UBound(MyAr) - 1)
If tempStr = "" Then
tempStr = MyAr(j)
Else
tempStr = tempStr & " " & MyAr(j)
End If
Next j
.Range("B" & i).Value = tempStr
.Range("C" & i).Value = MyAr(UBound(MyAr))
Next i
For i = 2 To lRow
If Not IsNumeric(.Range("C" & i).Value) Then
tempStr = ""
For j = 1 To Len(.Range("C" & i).Value)
If IsNumeric(Mid(.Range("C" & i).Value, j, 1)) Then
If tempStr = "" Then
tempStr = Mid(.Range("C" & i).Value, j, 1)
Else
tempStr = tempStr & Mid(.Range("C" & i).Value, j, 1)
End If
Else
Exit For
End If
Next
.Range("D" & i).Value = Mid(.Range("C" & i).Value, j)
.Range("C" & i).Value = tempStr
If Len(Trim(tempStr)) = 0 Then
MyAr = Split(.Range("A" & i).Value, strUnique)
.Range("C" & i).Value = MyAr(UBound(MyAr) - 1)
End If
End If
Next
.Columns("A:A").Replace What:=strUnique, Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Columns("D:D").Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With
End Sub
Screenshot:
Screenshot:
With your test data
EDIT: Now when I look at this code again, I see that it can be optimized much much further :)