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
Related
The below code works as long as there are more than one instance of the search criteria. However, if there is only one row that is listed as the what in the find function I receive the error "Could not set the list property. Invalid property array index"
Private Sub UserForm_Initialize()
Dim iRow As Integer, iMax As Integer
iRow = Cells.Find(What:="New Jersey Audit Adjustment", _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
iMax = Cells.Find(What:="New Jersey Audit Adjustment", _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False, SearchFormat:=False).Row
Me.ComboBox1.List = Worksheets("C-Proposal-19").Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox2.List = Worksheets("C-Proposal-19").Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox3.List = Worksheets("C-Proposal-19").Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox4.List = Worksheets("C-Proposal-19").Range("B" & iRow & ":B" & iMax).Value
Me.ComboBox5.List = Worksheets("C-Proposal-19").Range("B" & iRow & ":B" & iMax).Value
End Sub
The error occurs here Me.ComboBox1.List = Worksheets("C-Proposal-19").Range("B" & iRow & ":B" & iMax).Value if I have one row listed with "New Jersey Audit Adjustment"
When your range contains one cell, the .value will give you a value instead of an array. As the .list expects an array you could fill an array with one element or use addItem (see below)
If Worksheets("C-Proposal-19").Range("B" & iRow & ":B" & iMax).Cells.Count = 1 Then
Me.ComboBox1.AddItem Worksheets("C-Proposal-19").Range("B" & iRow & ":B" & iMax).Value
Else
Me.ComboBox1.List = Worksheets("C-Proposal-19").Range("B" & iRow & ":B" & iMax).Value
End If
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
I have a worksheet with names and addresses of people. I want to make a Userform that finds a person in Column 1 and then output the data from the following cells in the same row as a list. So the output would look like this:
John
Time Squares 12
New York
0123123123
I manage to find the cell and output the information, but I can't find a way to find and add the info in the following cells in the same row.
Dim FindString As String
Dim Rng As Range
FindString = txtSearch
If Trim(FindString) <> "" Then
With Sheets("servicepartner").Range("A:A")
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
MailFormat.Text = Rng.Value & vbNewLine
Else
MsgBox "Nothing found"
End If
End With
End If
Anyone have a suggestion on how to approach this issue? Thanks!
I solved this by setting up a variable (StringRow) with the rownumber of the search result. Then output Cells( StringRow, "B").Value & vbNewLinge & Cells( StringRow, "C") $ etc. etc. Works fine!
The code now looks like this:
Dim FindString As String
Dim Rng As Range
'This variable will find the Row number
Dim StringRow As Long
FindString = txtSearch
If Trim(FindString) <> "" Then
With Sheets("servicepartner").Range("A:A")
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
'Output Results (i shorted this to not give you a headache)
StringRow = Rng.Row
MailFormatKlant.Text = Rng.Value & vbNewLine & _
Sheets("servicepartner").Cells(StringRow, "B").Value & _
vbNewLine & Sheets("servicepartner").Cells(StringRow, "D").Value & _
" te " & Sheets("servicepartner").Cells(StringRow, "C").Value & _
vbNewLine & Sheets("servicepartner").Cells(StringRow, "F").Value & _
vbNewLine & Sheets("servicepartner").Cells(StringRow, "G").Value & _
Else
MsgBox "Nothing found"
End If
End With
End If
I hope someone finds this helpful :)
Here's what I was suggesting.
MailFormatKlant.Text = Rng.Value & _
vbNewLine & Rng.Offset(0,1).Value & vbNewLine & _
vbNewLine & Rng.Offset(0,3).Value & vbNewLine & _
vbNewLine & " te " & Rng.Offset(0,2).Value & vbNewLine & _
vbNewLine & Rng.Offset(0,5).Value & vbNewLine & _
vbNewLine & Rng.Offset(0,6).Value
I have one worksheet called mainData, which contains all data for ten products.
When I enter new data in mainData, I want to automatically copy the new data into the last row of another product worksheet. When I enter new data into mainData, how can I recognize the new data belongs to which product's worksheet, hence copy the new data into the product worksheet?
I'm stuck in copying it to another worksheet because I need to copy it to another ten worksheets according to product's type.
Here's what I've done to the mainData:
With Sheets("mainData")
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
.Range("B" & LastRow) = ComboBox1.Text
.Range("C" & LastRow) = TextBox1.Text
.Range("D" & LastRow) = TextBox2.Text
.Range("E" & LastRow) = TextBox3.Text
.Range("F" & LastRow) = TextBox4.Text
.Range("G" & LastRow) = TextBox5.Text
.Range("H" & LastRow) = ComboBox2.Text
.Range("I" & LastRow) = TextBox6.Text
.Range("J" & LastRow) = TextBox7.Text
.Range("K" & LastRow) = TextBox8.Text
Range("B32:B320").Select
ActiveWorkbook.Worksheets("mainData").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("mainData").Sort.SortFields.Add Key:=Range("B32:B305") _
, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
"prod1, prod2, prod3, prod4, prod5, prod6, prod7, prod8, prod9, prod10" _
, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("mainData").Sort
.SetRange Range("B32:W305")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
here's what i mean.when i enter new prod1 data into mainData worksheet, i want to automatically copy it into the last row of product 1 worksheet. i may enter many type of product i.e prod2,prod4 into mainData so how to copy this data into its particular product worksheet?
Is this what you are trying? (UNTESTED)
Also I have not done any error handling. I am sure you will take care of it :)
Dim prd As String
Dim ws As Worksheet
Dim LastRow As Long
'~~> Extract the number from the combobox
prd = Trim(Replace(ComboBox1.Text, "prod", ""))
'~~> Decide which sheet the data needs to be written to
'~~> Please ensure that sheets have names like "Product 1", "Product 2" etc
Set ws = ThisWorkbook.Sheets("Product " & prd)
'~~> Update it to the relevant sheet
With ws
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
.Range("B" & LastRow) = ComboBox1.Value
.Range("C" & LastRow) = TextBox1.Text
.Range("D" & LastRow) = TextBox2.Text
.Range("E" & LastRow) = TextBox3.Text
.Range("F" & LastRow) = TextBox4.Text
.Range("G" & LastRow) = TextBox5.Text
.Range("H" & LastRow) = ComboBox2.Value
.Range("I" & LastRow) = TextBox6.Text
.Range("J" & LastRow) = TextBox7.Text
.Range("K" & LastRow) = TextBox8.Text
'~~> Sort the data
With .Range("B2:W" & LastRow)
.Sort Key1:=ws.Range("B2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
End With
'~~> Update it in mainData
With Sheets("mainData")
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
.Range("B" & LastRow) = ComboBox1.Value
.Range("C" & LastRow) = TextBox1.Text
.Range("D" & LastRow) = TextBox2.Text
.Range("E" & LastRow) = TextBox3.Text
.Range("F" & LastRow) = TextBox4.Text
.Range("G" & LastRow) = TextBox5.Text
.Range("H" & LastRow) = ComboBox2.Value
.Range("I" & LastRow) = TextBox6.Text
.Range("J" & LastRow) = TextBox7.Text
.Range("K" & LastRow) = TextBox8.Text
'~~> Sort the data
With .Range("B2:W" & LastRow)
.Sort Key1:=Sheets("mainData").Range("B2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
End With
I do not really know how to explain this in a clear manner. Please see attached image
I have a table with 4 different columns, 2 are identical to each other (NAME and QTY). The goal is to compare the differences between the QTY, however, in order to do it. I must:
1. sort the data
2. match the data item by item
This is not a big deal with small table but with 10 thousand rows, it takes me a few days to do it.
Pleas help me, I appreciate.
My logic is:
1. Sorted the first two columns (NAME and QTY)
2. For each value of second two columns (NAME and QTY), check if it match with first two column. If true, the insert the value.
3. For values are not matched, insert to new rows with offset from the rows that are in first two columns but not in second two columns
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lastRow As Long, i As Long, newRow As Long
Dim aCell As Range, SrchRange As Range
Set ws = Sheets("Sheet1")
With ws
.Columns("A:B").Copy .Columns("G:G")
.Columns("G:H").Sort Key1:=.Range("G2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
lastRow = .Range("G" & Rows.Count).End(xlUp).Row
newRow = lastRow
Set SrchRange = .Range("G2:G" & lastRow)
lastRow = .Range("C" & Rows.Count).End(xlUp).Row
.Range("I1").Value = "NAME": .Range("J1").Value = "QTY"
For i = 2 To lastRow
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
Set aCell = SrchRange.Find(What:=.Range("C" & i).Value, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
.Range("I" & aCell.Row).Value = .Range("C" & i).Value
.Range("J" & aCell.Row).Value = .Range("D" & i).Value
Else
newRow = newRow + 1
.Range("I" & newRow).Value = .Range("C" & i).Value
.Range("J" & newRow).Value = .Range("D" & i).Value
End If
End If
Next
End With
End Sub
SNAPSHOT
Based on your above requirements, the logic totally changes and hence I am posting it as a different answer.
Also in your "This is Wonderful" snapshot above, there is a slight error. As per logic SAMPLE10 cannot come above SAMPLE11. It has to come after SAMPLE11.
See the below snapshot
And here is the code :)
Option Explicit
Sub sAMPLE()
Dim ws As Worksheet
Dim lastRow As Long, i As Long, newRow As Long, rw As Long
Dim aCell As Range, SrchRange As Range
Set ws = Sheets("Sheet1")
With ws
.Columns("A:B").Copy .Columns("G:G")
.Columns("G:H").Sort key1:=.Range("G2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
.Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
lastRow = .Range("G" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
.Range("H" & i).Value = GetLastNumbers(.Range("G" & i).Value)
If .Range("H" & i).Value <> 0 Then
.Range("G" & i).Value = Left(.Range("G" & i).Value, _
Len(.Range("G" & i).Value) - Len(.Range("H" & i).Value))
End If
Next i
.Columns("G:H").Sort key1:=.Range("H2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For i = 2 To lastRow
If .Range("H" & i).Value <> 0 Then _
.Range("G" & i).Value = .Range("G" & i).Value & .Range("H" & i).Value
Next i
.Columns("H:H").Delete
newRow = lastRow
Set SrchRange = .Range("G2:G" & lastRow)
lastRow = .Range("C" & Rows.Count).End(xlUp).Row
.Range("I1").Value = "NAME": .Range("J1").Value = "QTY"
For i = 2 To lastRow
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
Set aCell = SrchRange.Find(What:=.Range("C" & i).Value, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
.Range("I" & aCell.Row).Value = .Range("C" & i).Value
.Range("J" & aCell.Row).Value = Application.Evaluate("=SUMPRODUCT((C2:C" & lastRow _
& "=" & """" & .Range("C" & i).Value & """" & ")*(D2:D" & lastRow & "))")
Else
newRow = newRow + 1
.Range("I" & newRow).Value = .Range("C" & i).Value
.Range("J" & newRow).Value = .Range("D" & i).Value
End If
End If
Next
lastRow = .Range("G" & Rows.Count).End(xlUp).Row
For i = lastRow To 2 Step -1
If .Range("G" & i).Value = .Range("G" & i - 1).Value Then
.Range("H" & i - 1).Value = .Range("H" & i).Value + .Range("H" & i - 1).Value
If Application.WorksheetFunction.CountA(.Range("I" & i & ":J" & i)) = 0 Then
.Range("G" & i & ":J" & i).Delete Shift:=xlUp
Else
.Range("G" & i & ":H" & i).Delete Shift:=xlUp
End If
End If
Next i
lastRow = .Range("I" & Rows.Count).End(xlUp).Row
newRow = .Range("G" & Rows.Count).End(xlUp).Row
If lastRow <= newRow Then Exit Sub
.Range("I" & newRow & ":J" & lastRow).Sort key1:=.Range("I" & newRow), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For i = lastRow To newRow Step -1
If .Range("I" & i).Value = .Range("I" & i - 1).Value Then
.Range("J" & i - 1).Value = .Range("J" & i).Value + .Range("J" & i - 1).Value
.Range("I" & i & ":J" & i).Delete Shift:=xlUp
End If
Next i
End With
End Sub
Function GetLastNumbers(strVal As String) As Long
Dim j As Long, strTemp As String
For j = Len(strVal) To 1 Step -1
If Not IsNumeric(Mid(strVal, j, 1)) Then Exit For
strTemp = Mid(strVal, j, 1) & strTemp
Next j
GetLastNumbers = Val(Trim(strTemp))
End Function