I have a code , it loops through the destinated folder and every single file in the folder.
i have 2 questions
1) how can i modify this code and add it into my main code so that it would work without having compile error for not declaring the variables
For Each cell In Range("B1", Cells(Rows.count, "B").End(xlUp))
With cell
CodeExists = InStr(1, .Value, "testflow")
'Check that "Code:" exists
If CodeExists > 0 Then
.Value = Mid(.Value, CodeExists + 18, 3)
End If
End With
Next
2) if question 1 can't be done,
wks.Cells(BlankRow, 6).Replace What:="hometmastresh", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
wks.Cells(BlankRow, 6).Value = WorksheetFunction.Transpose(Split(wks.Cells(BlankRow, 6), "_"))
i would like to know how i can modify these 2 codes so that i can split my original string: "hometmastresh_enciivedexterXXtresh_tepootsXXXXXXXXXXXXXXtepootFile" that is currently in row E with "X" being unknown numbers and the fact that it will be different in every file.
i would like to split the original string into "XX" into Row F and "XXXXXXXXXXXXXX" into Row G respectively
i am still getting "01tresh_tepoots20191204756890tepootFile"
So after you have got the text using .Find, you can use Split. For example
Dim s As String
s = Split("01tresh_tepoots20191204756890tepootFile", "tepoot")(1)
s = Mid(s, 2, 8) & " " & Right(s, 6)
Debug.Print s
Edit
Your code
If Not aCell Is Nothing Then
aCell.Formula = Replace(aCell.Formula, , "")
s = Split(aCell.Value, "tepoots")(1)
End If
should be as shown below. This will put "20191204 756890" or whatever the number is in the cell.
If Not aCell Is Nothing Then
s = Split(aCell.Value, "tepoots")(1)
s = Mid(s, 2, 8) & " " & Right(s, 6)
aCell.Value = s
End If
Use Left/Right to get the ends of the string and concatenate them with a space
Dim v As String
'...
'...
If CodeExists > 0 Then
v = Mid(.Value, CodeExists + 18, 3)
.Value = Left(v, 8) & " " & Right(v, 6)
End If
Related
What I want the Macro to accomplish:
I want the user to be able to fill in data from E2 to E9 on the spreadsheet. When the user presses the "Add Car" button the macro is supposed to be executed. The makro then should take the handwritten data, copy everything from E2:E9 and put it into a table that starts at with C13 and spans over 7 columns, always putting the new set of data in the next free row. It is also supposed to check for duplicates and give an alert while not overwriting the original set of data
So my problem is, that I want the Macro I'm writing to take the information put into certain cells and then copy them into a table underneath.
I'm starting the Macro like this
Sub addData()
Dim lastrow As Long, nextBlankRow As Long
lastrow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlPrevious, _
MatchCase:=False).Row
nextBlankRow = lastrow + 1
Here I try to define how the Macro is supposed to find the last empty cell and also define lastrow and nextBlankRow.
After that I'm starting with a simple If statement to see if the person has at least something in E2 on the same sheet.
If Range("E2") = "" Then
MsgBox "Wählen Sie ein KFZ aus!"
Range("E2").Select
Exit Sub
End If
This works. When I'm not putting something into E2 I get the textbox with the alert.
Anyway if the IF-Statement is not triggered to exit the sub the Macro is given the instructions to get the information and put it in the table below
Cells(nextBlankRow, 3) = Range("E2")
Cells(nextBlankRow, 4) = Range("E3")
Cells(nextBlankRow, 5) = Range("E4")
Cells(nextBlankRow, 6) = Range("E5")
Cells(nextBlankRow, 7) = Range("E6")
Cells(nextBlankRow, 8) = Range("E7")
Cells(nextBlankRow, 9) = Range("E8")
Here seems to be a problem that probably relates to me failing to define variables correctly?
Because the Macro finds the right row but only overwrites into that row. So it ignores the fact that it "should" skip to the nextBlankrow which I defined earlier as
nextBlankRow = lastrow + 1
In addition to that I also have a line of code inplace which is supposed to check for duplicates
Dim p As Long, q As Long
p = 13
q = p + 1
Do While Cells(p, 3) <> ""
Do While Cells(q, 3) <> ""
If Cells(p, 3) = Cells(q, 3) And Cells(p, 4) = Cells(q, 4) Then
MsgBox "Datensatz schon vorhanden!"
Range(Cells(q, 3), Cells(q, 9)).ClearContents
Else
q = q + 1
End If
Loop
p = p + 1
q = p + 1
Loop
End Sub
Which always gives a false return. So even if the same set of Data is copied twice into the same row (as it does) it only "refreshes" the data and doesn't say "you're not allowed to do that".
I'm at a loss here.
Here's the full code for ease of use
Sub addData()
Dim lastrow As Long, nextBlankRow As Long
lastrow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlPrevious, _
MatchCase:=False).Row
nextBlankRow = lastrow + 1
If Range("E2") = "" Then
MsgBox "Wählen Sie ein KFZ aus!"
Range("E2").Select
Exit Sub
End If
Cells(nextBlankRow, 3) = Range("E2")
Cells(nextBlankRow, 4) = Range("E3")
Cells(nextBlankRow, 5) = Range("E4")
Cells(nextBlankRow, 6) = Range("E5")
Cells(nextBlankRow, 7) = Range("E6")
Cells(nextBlankRow, 8) = Range("E7")
Cells(nextBlankRow, 9) = Range("E8")
Dim p As Long, q As Long
p = 13
q = p + 1
Do While Cells(p, 3) <> ""
Do While Cells(q, 3) <> ""
If Cells(p, 3) = Cells(q, 3) And Cells(p, 4) = Cells(q, 4) Then
MsgBox "Datensatz schon vorhanden!"
Range(Cells(q, 3), Cells(q, 9)).ClearContents
Else
q = q + 1
End If
Loop
p = p + 1
q = p + 1
Loop
End Sub
```
Please, test the next code:
Sub copyRangeOnLastEmptyRow()
Dim sh As Worksheet, arr, lastERow As Long, matchCel As Range
Set sh = ActiveSheet
arr = sh.Range("E2:E9").value
lastERow = sh.Range("C" & sh.rows.Count).End(xlUp).row + 1
If lastERow < 13 Then lastERow = 13
'check if the range has not been alredy copied:
Set matchCel = sh.Range("C13:C" & lastERow - 1).Find(WHAT:=sh.Range("E2").value, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
If Not matchCel Is Nothing Then
MsgBox sh.Range("E2").value & " has been found in cell " & matchCel.Address & "."
'bring up the data of the existing row:
sh.Range("E3:E9").value = Application.Transpose(sh.Range(matchCel.Offset(0, 1), matchCel.Offset(0, 7)).value)
Exit Sub
End If
sh.Range("C" & lastERow).Resize(1, UBound(arr)).value = Application.Transpose(arr)
sh.Range("E2:E9").ClearContents
End Sub
This is my first time using VBA and macros in excel, or excel really for that matter. I appreciate any help or insight that you could give me, ranging from what functions to loops can help me succeed in this task
I am trying to get this workbook set up from this:
Sample Work Book
I get a list that has to be reordered in order to import into another system. My task list is as follows for a macro:
Names and companies have to be merged into one, if there is a different name of a person, that must be concatenated. There will not be two different companies per company header.
Every File ID per company must be concatenated
Individual fees must be replaced with total fee per company.
Sorted by internal ID #, A-Z
Only one header on the new sheet
To look like this:
Target Work Book
My code below runs this: Current Progress
Sub format()
Application.ScreenUpdating = False
'This is the setup to get rid of unnecessary cells'
Dim rCell As Range
Dim cRow As Long, LastRow As Long
LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'''Delete Merged Cells'''
With Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*Company Name:*", After:=[A1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
'''Delete Headings'''
With Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*File #*", After:=[A1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
''' Delete Sub Total"""
With Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*Sub Total:*", After:=[A1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
End Sub
Again, I appreciate any help on this matter. Thank you!
There are a lot of ways to loop through the cells.
I picked column D with the company name as it didn't have too much clutter.
It's usually good to find the last row, to not loop through cells that we don't need. THere is a lot of ways for doing so as well. Today we'll go with Range("D" & .Rows.Count).End(xlUp).Row.
For the loop, we can use the For next approach, example:
For i = 1 To Sheets(1).Range("A" & Sheets(1).Rows.Count).End(xlUp).Row
If Not Cells(i, 4).Value = "" Then
Next i
But this time, I went with the For Each, because I think it's a bit more readable.
Sub groupingEach()
Dim entry As Variant, prev As String, lRow As Long, lRow2 As Long
Dim inSht As Worksheet, outSht As Worksheet
Set inSht = Sheets(1)
Set outSht = Sheets(2)
lRow = inSht.Range("D" & inSht.Rows.Count).End(xlUp).Row 'last row
For Each entry In inSht.Range("D1:D" & lRow) 'loop 1st sheet
lRow2 = outSht.Range("D" & outSht.Rows.Count).End(xlUp).Row 'last row in output
If entry = prev And Not entry = "" Then
'-Group'
If InStr(outSht.Cells(lRow2, 3), entry.Offset(, 1)) = 0 Then 'does name exist?
outSht.Cells(lRow2, 3) = outSht.Cells(lRow2, 3) & vbNewLine & entry.Offset(, 1)
End If
outSht.Cells(lRow2, 5) = outSht.Cells(lRow2, 5) & vbNewLine & entry.Offset(, -2)
outSht.Cells(lRow2, 6) = outSht.Cells(lRow2, 6) + entry.Offset(, 2)
ElseIf Not entry = prev And Not entry = "" And Not entry = "Company" Then
'-New row
prev = entry 'Save company name for comparison
outSht.Cells(lRow2 + 1, 1) = entry.Offset(, -3)
outSht.Cells(lRow2 + 1, 2) = "Payable" 'Where to get this value?
outSht.Cells(lRow2 + 1, 3) = entry.Offset(, 1)
outSht.Cells(lRow2 + 1, 4) = entry
outSht.Cells(lRow2 + 1, 5) = entry.Offset(, -2)
outSht.Cells(lRow2 + 1, 6) = entry.Offset(, 2)
End If
Next entry
outSht.Cells(lRow2 + 3, 1).Value = "Grand Total:"
outSht.Cells(lRow2 + 3, 2).Formula = "=SUM(F:F)"
End Sub
From the examples, this should handle the document all the way from the Sample to the target. I wanted to loop the value copying, but the change in column order made it annoying.
I have one column with the names (First Name, Last Name) but sometimes there are the certificates, grades etc added to the names (ex: "John Smiths MBA"; "Susan Smiths FCA, ACCA"). The number of variable is countless but I identified the most common (there are many). Please help how to build the macro to clean this?
I've been using one by one, with:
Selection.Replace What:=" FCA,", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=True, _
ReplaceFormat:=False
But I guess there must be more efficient way to build this macro (and edit in case when new "unwanted extension is spotted).
Try this code
Sub Test()
Dim e, a, i As Long
Application.ScreenUpdating = False
For Each e In Array("MBA", "FCA", "ACCA", ", ")
Columns(1).Replace e, "", 2
Next e
With Range("A1", Cells(Rows.Count, "A").End(xlUp))
.Value = Evaluate(Replace("IF(COLUMN(#)=1,TRIM(#),TRIM(PROPER(#)))", "#", .Address))
End With
Application.ScreenUpdating = True
End Sub
I assume all the certificates and grades are 3 to 4 letters at the end of names, and it's all in UPPER case. Try the code based on this scenario.
Sub Test()
Dim name As String
i = 2
name = Range("A" & i).Value
While name <> ""
If Right(name, 4) = UCase(Right(name, 4)) Then
Range("A" & i).Value = Left(name, Len(name) - 4)
ElseIf Right(name, 3) = UCase(Right(name, 3)) Then
Range("A" & i).Value = Left(name, Len(name) - 3)
End If
i = i + 1
name = Range("A" & i).Value
Wend
End Sub
I want the font colour to reflect the colour written as a word. e.g. Every time the word "red" appears in a string I want the font of the word red to be red (or highlighted in red). I have strings of text in cells with the name of a site, a deadline and RAG status. These are within one cell, separated by a line break (char(10)). I have columns of cells based on deadline date, and rows by work type so I can't easily split each text segment into its own cell and use conditional formatting without breaking this tabular layout. The string is built from code which concatenates text, and then referenced in formula.
I can write basic VBA but haven't a clue how i could do this but have attached the concat code (from Chandoo) to illustrate how the text string is built up.
Function concat(useThis As Range, Optional delim As String) As String
' this function will concatenate a range of cells and return one string
' useful when you have a rather large range of cells that you need to add up
For Each cell In useThis
If CStr(cell.Value) <> "" And CStr(cell.Value) <> " " Then
retVal = retVal & CStr(cell.Value) & dlm
End If
Next
If dlm <> "" Then
retVal = Left(retVal, Len(retVal) - Len(dlm))
End If
concat = retVal
End Function
Can anybody advise how I should approach this please? Or suggest any alternatives to this approach.
First, you need to find the start location of the search term within the string, so
startRed = InStr(0,searchstring,"Red",CompareMethod.Text)
then, within the specified cell, use the characters property and the known length to change the color
With Cell.Characters(Start:= startRed, Length:= Len("Red")).Font
.Color = RGB(255,0,0)
Do this for each desired color and your cells will be changed as needed
Thanks RGA. I used what you put to write the below. Not the neatest but it allows me to colour each linebreak on my sheet with the corresponding colour to the text.I had to convert my formula to values for it to work. Thanks again, I wouldn't have had a clue where to start without you.
Sub ColourText2()
TurnOff
Dim startRed As Integer, startChar As Integer, startAmber As Integer, startGreen As Integer, x As Integer, i As Integer, startLB As Integer, endLB As Integer, iCount As Integer
Dim searchString As String, searchChar As String
Dim clr As Long
Dim cell As Range
For x = 6 To 22
iCount = Worksheets("MySheet").Range("D" & x & ":S" & x).Count
Range("C" & x).Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("C" & x & ":S" & x), Type:=xlFillDefault
Range("C" & x & ":S" & x).Select
Worksheets("MySheet").Calculate
Range("D" & x & ":S" & x).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
For Each cell In Worksheets("MySheet").Range("D" & x & ":S" & x)
searchString = cell
Application.StatusBar = i & "of: " & iCount
startChar = 1
For startLB = 1 To Len(cell)
cell.Select
If startChar = 1 Then
startLB = 1
endLB = 1
Else
startLB = InStr(endLB, searchString, Chr(10), vbTextCompare)
End If
startGreen = InStr(endLB, searchString, "green", vbTextCompare)
'MsgBox startGreen
startAmber = InStr(endLB, searchString, "amber", vbTextCompare)
'MsgBox startAmber
startRed = InStr(endLB, searchString, "red", vbTextCompare)
'MsgBox startRed
endLB = InStr(endLB + 1, searchString, Chr(10), vbTextCompare)
If startGreen < endLB And startGreen <> 0 Then
startChar = startGreen
cell.Characters(startLB, endLB - startLB).Font.Color = RGB(0, 153, 0)
ElseIf startAmber < endLB And startAmber <> 0 Then
startChar = startAmber
cell.Characters(startLB, endLB - startLB).Font.Color = RGB(226, 107, 10)
cell.Characters(startLB, endLB - startLB).Font.Underline = xlUnderlineStyleSingle
ElseIf startRed < endLB And startRed <> 0 Then
startChar = startRed
cell.Characters(startLB, endLB - startLB).Font.Color = RGB(255, 0, 0)
cell.Characters(startLB, endLB - startLB).Font.Underline = xlUnderlineStyleSingle
Else
GoTo MoveOn
End If
If startChar = 0 Then GoTo MoveOn
MoveOn:
Next
Next cell
x = x + 1
Next
TurnON
Application.StatusBar = False
MsgBox "finished"
End Sub
I am using the following code to append values within a single cell by checking the values of other cells. What I want to do next is change the font color of the value I am appending, and keep any existing font colors. Ex: Value of a1 is "". I then append the value "abc " in green. I then append the value "123 " in red. I want the cell to show:
[(red)(green)]
["abc 123 "]
My code:
If Cells(ActiveCell.Row, 6).Value = "Control" Then
bit_value = "(" & Application.WorksheetFunction.VLookup(Cells(ActiveCell.Row, 5).Value, Range("Output"), total_bits + 3, False) & ")" & high_low & " "
Cells(ActiveCell.Row, 7).Value = Cells(ActiveCell.Row, 7).Value & bit_value
End If
My Data:
504003 Control 2 11 55 12 21 00010001 01010101 00010010 00100001
504003 Control 2 11 55 12 20 00010001 01010101 00010010 00100000
UPDATE:
By utilizing Tim's code, I arrived at the changes below, and it does exactly what I needed.
bitColor = IIf(ActiveCell.Value = 0, RGB(255, 0, 0), RGB(0, 0, 255))
If Cells(ActiveCell.Row, 6).Value = "Control" Then
With Cells(ActiveCell.Row, 7)
bit_value = "(" & Application.WorksheetFunction.VLookup(Cells(Active _
Cell.Row, 5).Value,Range("Output"), total_bits + 3, False) & ")"
AddValue Cells(ActiveCell.Row, 7), bit_value, bitColor
End With
End If
Here's how to add text to a cell without losing any existing formatting:
Sub Tester()
With ActiveSheet
AddValue .Range("A1"), "Hello", vbRed
AddValue .Range("A1"), "Hello", vbGreen
AddValue .Range("A1"), "Hello", vbBlue
End With
End Sub
Sub AddValue(rngVal As Range, val, theColor As Long)
Const SEP As String = " "
Dim firstChar As Long, extra As Long
firstChar = 1 + Len(rngVal.Value)
extra = IIf(firstChar = 1, 0, 1)
With rngVal
.Characters(firstChar).Text = IIf(Len(rngVal.Value) > 0, SEP, "") & val
.Characters(firstChar + extra, Len(val)).Font.Color = theColor
End With
End Sub
NOTE: you only get up to 255 characters using this approach