I have a simple problem for which I can't find a solution to. I can get values into a MsgBox in my code in Excel as for example: aaaaaaaa, bbbbbbbb, cccccccc, dddddddd etc. I would like to get the comma separated values from this MsgBox into cells starting from for example C15, C16, C17, C18 etc. as following:
C15: aaaaaaaa
C16: bbbbbbbb
C17: cccccccc
C18: dddddddd
C19: etc.
I can't find a solution to my problem although I have tried to Google an answer for a couple of hours. All help appreciated!
Sub ComSepList()
Dim lr As Long, rng As Range, c As Range, fLoc As Range
Dim fAdr As String, rngOut As Range
Dim xArr() As String
Dim tttt As String
lr = Cells(Rows.Count, 2).End(xlUp).Row
Set rngOut = Range("C15")
Set rng = Range("B2:B" & lr)
For Each c In rng
'MsgBox c
Set fLoc = Range("A:A").Find(c.Value, , xlValues)
If Not fLoc Is Nothing Then
fAdr = fLoc.Address
Do
If fLoc.Offset(0, 6) = "1" Then
c.Offset(0, 4) = c.Offset(0, 4).Value & fLoc.Offset(0, 7).Value & ", "
End If
fLoc.Value = c.Value
Set fLoc = Range("A:A").FindNext(fLoc)
Loop While fAdr <> fLoc.Address
tttt = Left(c.Offset(0, 4).Value, Len(c.Offset(0, 4).Value) - 1)
End If
'Columns("F").AutoFit
Next
MsgBox tttt
rngOut.Resize(UBound(Split(tttt.Text, ","))).Value = Application.Transpose(Split(tttt.Text, ","))
End Sub
Sub kjlkjlkj()
Dim t As String
t = InputBox("String")
ActiveSheet.Range("C15").Resize(UBound(Split(t, ",")) + 1).Value = _
Application.Transpose(Application.Trim(Split(t, ",")))
End Sub
Related
I have been trying to work on this sumif code for a while but keep getting an error (Run Time Error 1004 'Unable to get the SumIfs property of the Worksheet Function class). anyone have any ideas as to why?
I am trying to match an ID that I have on column B (basically a table) and match it with all the IDs present on column F. If there are matches, then i want to take all the quantities/values the ID has and sum them. Then place the sum on column C next to the corresponding ID
lastrowB = cnCS.Range("B" & Rows.Count).End(xlUp).Row
Set rngtotalvalue = cnCS.Range("B50:B" & lastrowB)
lastrow = cnCS.Range("F" & Rows.Count).End(xlUp).Row
Set datarange = cnCS.Range("F3:T" & lastrow)
Dim rgColumnC As Range, n As Long
For Each rgColumnC In rngtotal.Rows
Set columnB = cnCS.Range("S3:S" & lastrow)
totalvalue = Application.WorksheetFunction.SumIf(datarange, rngtotalvalue, columnB)
rgColumnC.Cells(1, 2) = totalvalue
Next rgColumnC
Dim rgWeightRow As Range
For Each rgWeightRow In datarange.Rows
sAccountNumber = rgWeightRow.Cells(1, 1)
sEuro = rgWeightRow.Cells(1, 14)
sTotalValue = Application.WorksheetFunction.VLookup(sAccountNumber, rngtotal, 2, False)
sWeight = (sEuro / totalvalue)
rgWeightRow.Cells(1, 15).Value = sWeight
Next rgWeightRow
Here's one approach using a dictionary to track the sums:
Sub SumUp()
Dim dict As Object, data As Range, rw As Range, k, v
Set dict = CreateObject("scripting.dictionary")
Set data = Sheets("data").Range("A2:X7000") 'for example
For Each rw In data.Rows
k = rw.Columns("B").Value 'id's in ColB
v = rw.Columns("X").Value 'values in ColX
If Len(k) > 0 And IsNumeric(v) Then
dict(k) = dict(k) + v
End If
Next rw
'output the sums
With Sheets("Summary").Range("A2")
.Resize(dict.Count).Value = Application.Transpose(dict.keys)
.Offset(0, 1).Resize(dict.Count).Value = Application.Transpose(dict.Items)
End With
End Sub
EDIT: seems like this would be closer to what you want
Sub Tester()
Dim ws As Worksheet, addrB As String, addrF As String, addrS As String, frm As String
Set ws = ActiveSheet
addrB = ws.Range("B50:B" & ws.Cells(Rows.Count, "B").End(xlUp).Row).Address
addrF = ws.Range("F3:F" & ws.Cells(Rows.Count, "F").End(xlUp).Row).Address
addrS = ws.Range("S3:S" & ws.Cells(Rows.Count, "F").End(xlUp).Row).Address
With ws.Range(addrB).Offset(0, 1)
.FormulaArray = "=SUMIF(" & addrF & "," & addrB & "," & addrS & ")"
.Value = .Value
End With
End Sub
I have a excel sheet like at below. I want to find some strings in my excel's third cell. The string is 180 days. When the cell value includes 180 days, I want write previous cells value in next to empty cells like in below picture. I want to write process plan in first cell, operation title in second cell. I wrote this codes but it's not working like what I want.
Sub Button1_Click()
Dim excelRange As Long
Dim i As Long
Dim k As Long
'Dim txt As String
excelRange = ActiveSheet.Cells(1048576, 3).End(xlUp).Row
k = 2
For a = 2 To excelRange
txt = Cells(a, 3)
k = a
If InStr(1, txt, "180 days") > 0 Then
For i = a To 2 Step -1
txt1 = Cells(i, 3)
If InStr(1, txt1, "Oper Title") > 0 Then
Cells(a, 2) = Cells((k + 1), 3)
ElseIf InStr(1, txt1, "Process") > 0 Then
Cells(a, 1) = Cells(k, 3)
Else:
k = k - 1
End If
Next i
End If
Next a
End Sub
Sub test()
Dim excelRange As Range
Dim criteriRange As Range
Dim evaluateRange As Range
Dim c As Range
Dim i As Long
Set excelRange = Range("C1:C" & Cells(1048576, 3).End(xlUp).Row)
For Each cell In excelRange
If UCase(cell.Text) Like "*180 DAY*" Then
If criteriRange Is Nothing Then
Set criteriRange = cell
Else
Set criteriRange = Union(criteriRange, cell)
End If
End If
Next
If Not criteriRange Is Nothing Then
For Each c In criteriRange
For i = c.Row To 1 Step -1
If UCase(Cells(i, 3)) Like "*PROCESS PLAN*" Then
c.Offset(0, -2) = Cells(i, 3)
Exit For
End If
Next
For i = c.Row To 1 Step -1
If UCase(Cells(i, 3)) Like "*OPER TITLE*" Then
c.Offset(0, -1) = Cells(i + 1, 3)
Exit For
End If
Next
Next
End If
End Sub
Instead of looping through a range, your macro will run much faster if you use the Range.Find method.
In your code, you did not check to ensure that all of your sets of Process | Title | 180 Days are complete. I added that to the code below, by making sure that the Process and Title rows were found after the previous 180 day row (or before the 180 day row for the first instance).
In your code, you did not check to see if the cells where you want to output this information are, in fact, empty. If you really want to do that, you can easily modify this code to check these cells before writing to them.
Hopefully, through the comments and the use of meaningful variable names, you will be able to understand what is going on. But you might want to also read through VBA Help for the Range.Find method.
In general, we search down to find the 180 day row, then search up from there to find the associated Process and Title rows.
If a preceding Process or Title row should be before the preceding 180 day row, then we have an incomplete set, output the error message, and terminate the procedure.
If necessary, you could develop procedures to deal with incomplete data sets.
Option Explicit
Sub Info()
Dim searchRng As Range, C As Range, cProcessPlan As Range, cOperTitle As Range
Dim firstAddress As String 'to check when we are done
Dim lastAddress As String 'to check for incomplete data sets
'Where are we looking?
Set searchRng = ThisWorkbook.Worksheets("Sheet1").Columns(3)
With searchRng
Set C = .Find(what:="180 Days", after:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlPart, searchorder:=xlByRows, _
searchdirection:=xlNext, MatchCase:=False)
If Not C Is Nothing Then
firstAddress = C.Address
lastAddress = C.Address
Set cOperTitle = .Find(what:="Oper Title", after:=C, searchdirection:=xlPrevious)
Set cProcessPlan = .Find(what:="Process Plan", after:=C, searchdirection:=xlPrevious)
If Not cOperTitle Is Nothing Or Not cProcessPlan Is Nothing Then
'check for full set
If cOperTitle.Row > Range(lastAddress).Row Or cProcessPlan.Row > Range(lastAddress).Row Then
MsgBox "Incomplete Data Set" & vbLf & "Before: " & C.Address
Exit Sub
End If
C.Offset(0, -1) = cOperTitle.Offset(1, 0)
C.Offset(0, -2) = cProcessPlan
Else
MsgBox "Title or Process Plan not found"
Exit Sub
End If
Do
Set C = .Find(what:="180 Days", after:=C, LookIn:=xlValues, _
lookat:=xlPart, searchorder:=xlByRows, _
searchdirection:=xlNext, MatchCase:=False)
If C.Address = firstAddress Then Exit Do
Set cOperTitle = .Find(what:="Oper Title", after:=C, searchdirection:=xlPrevious)
Set cProcessPlan = .Find(what:="Process Plan", after:=C, searchdirection:=xlPrevious)
'check for a full set
If cOperTitle.Row < Range(lastAddress).Row Or cProcessPlan.Row < Range(lastAddress).Row Then
MsgBox "Incomplete Data Set" & vbLf & "Between: " & lastAddress & " and " & C.Address
Exit Sub
End If
C.Offset(0, -1) = cOperTitle.Offset(1, 0)
C.Offset(0, -2) = cProcessPlan
lastAddress = C.Address
Loop
End If
End With
'next stuff
End Sub
Using a variant array is fast.
Sub test()
Dim Ws As Worksheet
Dim rngDB As Range
Dim vDB As Variant
Dim vRow(), vTitle(), vProcess()
Dim i As Long, j As Long, k As Long, m As Long
Set Ws = ActiveSheet
With Ws
Set rngDB = .Range("a1", .Range("c" & Rows.Count).End(xlUp))
End With
vDB = rngDB
For i = 1 To UBound(vDB, 1)
If InStr(vDB(i, 3), "180 days") Then
j = j + 1
ReDim Preserve vRow(1 To j)
vRow(j) = i
ElseIf InStr(vDB(i, 3), "Oper Title") Then
k = k + 1
ReDim Preserve vTitle(1 To k)
vTitle(k) = vDB(i + 1, 3)
ElseIf InStr(vDB(i, 3), "Process") Then
m = m + 1
ReDim Preserve vProcess(1 To m)
vProcess(m) = vDB(i, 3)
End If
Next i
For i = 1 To j
vDB(vRow(i), 1) = vProcess(i)
vDB(vRow(i), 2) = vTitle(i)
Next i
rngDB = vDB
End Sub
I'm trying to concatenate rows.
The first cell is populated correctly; however, each cell after that is the same as the first cell.
The first cell is FS_Tier_1 , FS_CAP_1_001
The next cell should be FS_Tier_1 , FS_CAP_1_002
The cell after that should be FS_Tier_1 , FS_CAP_1_003, and so on.
Each cell shows FS_Tier_1 , FS_CAP_1_001.
Sub Concatenate_Cap1()
With Worksheets("PD Code Structure")
Dim i As Integer
Dim cell As Range
Dim Rng1 As Range
Set Rng1 = Range("F2:F1006")
i = 2
For Each cell In Rng1
If InStr(Cells(i, 3).Value, "FS_Tier_") And InStr(Cells(i, 8).Value, "FS_CAP_1_") Then
Range("F2:F1006").Formula = Cells(i, 3).Value & " , " & Cells(i, 8).Value
i = i + 1
End If
Next cell
End With
End Sub
You're setting the whole range to the same value here.
Range("F2:F1006").Formula = Cells(i, 3).Value & " , " & Cells(i, 8).Value
Something like this should work:
Sub Concatenate_Cap1()
Dim c As Range, rw As range, v3, v8
For Each c in Worksheets("PD Code Structure").Range("F2:F1006")
v3 = c.EntireRow.cells(3).value
v8 = c.EntireRow.cells(8).value
If InStr(v3, "FS_Tier_") And InStr(v8, "FS_CAP_1_") Then
c.value = v3 & " , " & v8
End If
Next cell
End Sub
Hello and thanks in advance for any assistance. I have a work sheet with two tabs named DATA PULL and LIST. The LIST tab contains a list of keywords (250 words) in column A. I need to search for those key words in columns P and Q on the DATA PULL tab and return any matches to column I(the data is in a table). Columns P and Q contain multiple words or sentences.
The code below does what I need but the list of key words is on the same sheet. This code also deletes letters from my table headers for some reason.
Sub GetWords()
Dim wrdLRow As Integer
Dim wrdLp As Integer
Dim CommentLrow As Integer
Dim CommentLp As Integer
Dim fndWord As Integer
Dim Sht As Worksheet
On Error Resume Next 'Suppress Errors... for when we don't find a match
'Define worksheet that has data on it....
Set Sht = Sheets("DATA PULL")
'Get last row for words based on column A
wrdLRow = Sht.Cells(Rows.Count, "A").End(xlUp).Row
'Get last row for comments based on column C
CommentLrow = Sht.Cells(Rows.Count, "P").End(xlUp).Row
'Loop through lists and find matches....
For CommentLp = 2 To CommentLrow
For wrdLp = 2 To wrdLRow
'Look for word...
fndWord = Application.WorksheetFunction.Search(Sht.Cells(wrdLp, "A"), Sht.Cells(CommentLp, "P"))
'If we found the word....then
If fndWord > 0 Then
Sht.Cells(CommentLp, "I") = Sht.Cells(CommentLp, "I") & "; " & Sht.Cells(wrdLp, "A")
fndWord = 0 'Reset Variable for next loop
End If
Next wrdLp
Sht.Cells(CommentLp, "I") = Mid(Sht.Cells(CommentLp, "I"), 3, Len(Sht.Cells(CommentLp, "I")) - 2)
Next CommentLp
End Sub
Any help is greatly appreciated.
LIST
DATAPULL
Some tips for your code:
Using a
On error Resume Next
like you are using is a bad practice and can result in trouble. You might have other errors that won't show up because of that, and this will prevent you from debugging them and finding the problem. I would recommend using it only before the problematic line, and after that using
On Error goto 0
to resume showing and finding other possible errors.
A way of totally avoiding having to use "On Error Resume Next" is using the "Like" Operator. If you use
If Sht.Cells(CommentLp, "P") Like "*" & Sht.Cells(wrdLp, "A") & "*" Then
Sht.Cells(CommentLp, "I") = Sht.Cells(CommentLp, "I") & "; " & Sht.Cells(wrdLp, "A")
End If
You can do the same thing without worrying about errors. Basically, "Like" does a search to see if a text looks like the other. The two "*" means any kind and number of characters, so all together means that Sht.Cells(CommentLp, "P") must be like: any kind and number of characters, followed by the value of Sht.Cells(wrdLp, "A"), followed by any kind or number of characters. Just like "Search" =) !
Doing this change also forced me to adapt the way you are dealing with the starting "; " in your code, but also for a better way:
Dim wrdLRow As Integer
Dim wrdLp As Integer
Dim CommentLrow As Integer
Dim CommentLp As Integer
Dim fndWord As Integer
Dim DataSht As Worksheet
Dim ListSht as Worksheet
'Define the worksheets
Set DataSht = Sheets("DATA PULL")
Set ListSht = Sheets("LIST")
'Get last row for words based on column A
wrdLRow = ListSht.Cells(Rows.Count, "A").End(xlUp).Row
'Get last row for comments based on column C
CommentLrow = DataSht.Cells(Rows.Count, "P").End(xlUp).Row
For CommentLp = 2 To CommentLrow
For wrdLp = 2 To wrdLRow
If LCASE(DataSht.Cells(CommentLp, "P")) Like "*" & LCASE(ListSht.Cells(wrdLp, "A")) & "*" Then
If DataSht.Cells(CommentLp, "I") <> "" Then
DataSht.Cells(CommentLp, "I") = DataSht.Cells(CommentLp, "I") & "; " & ListSht.Cells(wrdLp, "A")
Else
DataSht.Cells(CommentLp, "I") = ListSht.Cells(wrdLp, "A")
End If
ElseIf LCASE(Sht.Cells(CommentLp, "Q")) Like "*" & LCASE(Sht.Cells(wrdLp, "A")) & "*" Then
If NewSht.Cells(writeRow, "A") <> "" Then
NewSht.Cells(writeRow, "A") = NewSht.Cells(writeRow, "A") & "; " & Sht.Cells(wrdLp, "A")
Else
NewSht.Cells(writeRow, "A") = Sht.Cells(wrdLp, "A")
End If
End If
Next wrdLp
Next CommentLp
This code runs for me without a problem, but so did yours. I am assuming you didn't share your whole code, also because you mentioned two columns and only wrote the code for one. I think the problem might be in the part you didn't share, and perhaps this modification I wrote, without the "On Error Resume Next", you help you find it!
I just hoped I didn't get confused with the variables and list, but I think now you can have a good idea of what I am doing. Hope it helps.
I think you could try this:
EDITED VERSION:
Option Explicit
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LRA As Long, i As Long, LRP As Long, LRQ As Long, LRI As Long
Dim SearchingValue As String
Dim rng As Range, cell As Range
With ThisWorkbook
Set ws1 = .Worksheets("DATA PULL")
Set ws2 = .Worksheets("LIST")
With ws1
LRP = .Cells(.Rows.Count, "P").End(xlUp).Row
LRQ = .Cells(.Rows.Count, "Q").End(xlUp).Row
Set rng = .Range("P1:P" & LRP, "Q1:Q" & LRQ)
End With
With ws2
LRA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LRA
SearchingValue = .Range("A" & i).Value
For Each cell In rng
If InStr(1, cell.Value, SearchingValue) > 0 Then
With ws1
LRI = .Cells(.Rows.Count, "I").End(xlUp).Row
.Range("I" & LRI + 1).Value = "Value " & """" & .Range("A" & i).Value & """" & " appears in sheet DATA PULL, " & "column " & cell.Column & ", row " & cell.Row & "."
Exit For
End With
End If
Next cell
Next i
End With
End With
End Sub
I need to create a VBA script in excel that chanages an order number from having "CD" at the front to "CD" at the end so from "CD00001" to "00001CD"
Any help would be awesome. all of the order numbers are in Column B and start at row 5. please help.
What i have so far:
Private Sub OrderNumber_Click()
Dim Val As String
Dim EndC As Integer
EndC = Worksheets("Raw Data Upload").Range("A1048576").End(xlUp).Row
For i = 5 To EndC
Val = Right("B" & i, Len("B" & i) - 2) & Left("B" & i, 2)
Range("B" & i).Value = Val
Next
End Sub
This replaces the order numbers with B5, B6 and so on but if i put this function into Excel itself it works fine.
Like this? DO you want it in column B?
Option Explicit
Private Sub OrderNumber_Click()
Dim i As Long
Dim val As String
Dim EndC As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Raw Data Upload")
EndC = ws.Range("A1048576").End(xlUp).Row
For i = 5 To EndC
val = ws.Cells(i, "A")
Range("B" & i).Value = Mid$(val, 3, Len(val) - 2) & Left$(val, 2)
Next i
End Sub
dim beginStr, endStr, originalStr, outputStr as string
dim rng as range
'put the below into a loop, assigning a rng to the desired cell each time
originalStr = rng.value ' Change to chosen range
beginStr = left(originalStr,2)
endStr = right(originalStr, len(originalStr) - 2)
outputStr = endStr + beginStr
Range("B" & i).Value = outputStr
I haven't got a copy of Excel to test this on but it should work.
Simply use:
Right(Range("B" & i), Len(Range("B" & i)) - 2) & Left(Range("B" & i), 2)
An alternative is to set up the cell as a Range():
Sub t()
Dim cel As Range
Dim endC As Long
endC = Worksheets("Raw Data Upload").Range("A1048576").End(xlUp).Row
For i = 5 To endC
Set cel = Range("B" & i)
myVal = Right(cel, Len(cel) - 2) & Left(cel, 2)
Range("B" & i).Value = myVal
Next
End Sub
Currently, when you do Right("B" & i, Len("B" & i) - 2) & Left("B" & i, 2), for row 5, this becomes Right("B5", Len("B5") - 2) & Left("B5", 2) then this evaluates to simply:
Right("B5",0) & Left("B5",2), which is
[nothing] & B5, finally becoming
B5
Note the lack of using B5as a range. Instead it's being treated as a string.
(Also, I'm assuming this is to be run on the ActiveSheet. If not, please add the worksheet before the range, i.e. Worksheets("Raw Data Upload").Range("B" & i)...)
Try this
Private Sub OrderNumber_Click()
Dim cell As Range
With Worksheets("Raw Data Upload")
For Each cell in .Range("B5", .Cells(.Rows.Count, 2).End(xlUp))
cell.Value = Right(cell.Value, Len(cell.Value) - 2) & Left(cell.Value, 2)
Next
End With
End Sub