What I am trying to achieve:
I want to fully automate the process of cleaning up exported data.
I want to move the data in the overflow rows into their prospective column. I have tried the following code in VBA. (This is trying to identify the # symbol in the emails and respectively move all email address two places to the right).
Sub qwerty()
Dim D As Range, r As Range
Set D = Intersect(ActiveSheet.UsedRange, Range("D:D"))
For Each r In D
If Left(r.Text, 2) = "#" Then
r.Copy r.Offset(0, 1)
r.Clear
End If
Next r
End Sub
Once the data is in the correct column I need to automate the movement into the correct row. I can easily have them shift up but if one contact doesn't have an email address (as an example) then the emails will be in the wrong rows when they shift up.
Something like this should work:
Sub Tester()
Dim rw As Range, currRow As Long
Dim v, col As Long
Set rw = ActiveSheet.Rows(2)
currRow = 0
Do While rw.Row <= ActiveSheet.UsedRange.Rows.Count
If rw.Cells(2).Value <> "" Then
currRow = rw.Row 'moving "overflow" items to this row...
Else
If currRow > 0 Then
v = rw.Cells(4).Value
col = 0
'Figure out which column item should be moved to...
' "[" is a special character to "Like", so needs to be
' enclosed in "[]"
If v Like "[[]M]:*" Then
col = 8
ElseIf v Like "[[]E]:*" Then
col = 6
ElseIf v Like "[[]H]:*" Then
col = 7
ElseIf v Like "[[]Address]:*" Then
col = 9
End If
'Got a pattern match, so move this item...
'Change ".Copy" to ".Cut" when you're done testing...
If col > 0 Then rw.Cells(4).Copy ActiveSheet.Cells(currRow, col)
End If
End If
Set rw = rw.Offset(1, 0) 'next row....
Loop
End Sub
Related
I've written the following code to check if values in row A equal to "Forecast" then Range D5:D53 should have its contents cleared.
Row 1 is a vlookup so there's a formula that derives "Actual" or "Forecast"
Dim k As Integer
For k = 1 To 13
If Sheets("2017 Forecast").Cells(k, 1).Value = "Forecast" Then
Sheets("2017 Forecast").Range("D5:D53").Select.ClearContents
End If
Next k
There's no need to use Select before you use ClearContents.
Also, try adding UCase to make sure you don't have any CAPITAL letter in the middle of your text.
Code
Dim k As Integer
With ThisWorkbook.Sheets("2017 Forecast")
For k = 1 To 13
If UCase(.Cells(k, 1).Value2) = "FORECAST" Then
.Range("D5:D53").ClearContents
End If
Next k
End With
Maybe this works for you?
Option explicit
Sub Compare skies()
Dim k As long
Dim ValueRead as variant
With Sheets("2017 Forecast")
For k = 1 To 13
ValueRead = .Cells(k, 1).Value
' Slow, case insensitive string comparison '
If strcomp(ValueRead,"Forecast",vbtextcompare) = 0 Then
.Range("D5:D53").ClearContents ' You want to clear the exact same range 13 times? '
Elseif strcomp(ValueRead,"Actual",vbtextcompare) <> 0 then
Msgbox("VLOOKUP returned a value outside of Actual and Forecast")
End if
Next k
End with
End sub
I am trying to make an auto scheduling program with an excel.
For example, each number is certain job assigned to the person given day.
1/2 1/3 1/4 1/5
Tom 1 2 2 ?
Justin 2 3 1 ?
Mary 3 3 ?
Sam 1 ?
Check O O X ? ## check is like =if(b2=c2,"O","X")
The things I want to make sure is every person is given a different job from yesterday.
My idea
while
randomly distribute jobs for 1/5
wend CheckCell = "O"
But I found that checking cell in the vba script doesn't work - the cell is not updated in each while loop.
Could you give me a little pointer for these kinds of program? Because I am new to vbaScript, any kinds of help would be appreciated.
Using VBA, I'm sure there are better ways to do this, but this will check the values from the penultimate column against values from last column and if they match it will write "O" to under the last column, else it will write "X":
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
counter = 0 'set counter
For i = 2 To LastRow 'loop through penultimate column and add values to array
If ws.Cells(i, LastCol - 1).Value <> "" Then
Values = Values & ws.Cells(i, LastCol - 1) & ","
End If
Next i
Values = Left(Values, Len(Values) - 1)
Values = Split(Values, ",") 'split values into array
For i = 2 To LastRow 'loop through last column and add values to array
If ws.Cells(i, LastCol).Value <> "" Then
ValuesCheck = ValuesCheck & ws.Cells(i, LastCol) & ","
End If
Next i
ValuesCheck = Left(ValuesCheck, Len(ValuesCheck) - 1)
ValuesCheck = Split(ValuesCheck, ",")
For y = LBound(Values) To UBound(Values) 'loop through both arrays to find all values match
For x = LBound(ValuesCheck) To UBound(ValuesCheck)
If Values(y) = ValuesCheck(x) Then counter = counter + 1
Next x
Next y
If counter = UBound(Values) + 1 Then 'if values match
ws.Cells(LastRow + 1, LastCol).Value = "O"
Else 'else write X
ws.Cells(LastRow + 1, LastCol).Value = "X"
End If
End Sub
just to clarify are you looking to implement the random number in the vba or the check.
To do the check the best way would be to set the area as a range and then check each using the cells(r,c) code, like below
Sub checker()
Dim rng As Range
Dim r As Integer, c As Integer
Set rng = Selection
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
If rng.Cells(r, c) = rng.Cells(r, c + 1) Then
rng.Cells(r, c).Interior.Color = RGB(255, 0, 0)
End If
Next c
Next r
End Sub
this macro with check the text you have selected for the issue and change the cell red if it matches the value to the right.
To make it work for you change set rng = selection to your range and change the rng.Cells(r, c).Interior.Color = RGB(255, 0, 0) to the action you want
A sligthly different approach than the other answers.
Add this function:
Function PickJob(AvailableJobs As String, AvoidJob As String)
Dim MaxTries As Integer
Dim RandomJob As String
Dim Jobs() As String
Jobs = Split(AvailableJobs, ",")
MaxTries = 100
Do
MaxTries = MaxTries - 1
If MaxTries = 0 Then
MsgBox "Could find fitting job"
End
End If
RandomJob = Jobs(Int((1 + UBound(Jobs)) * Rnd()))
Loop Until RandomJob <> AvoidJob
PickJob = RandomJob
End Function
And put this formula in your sheet
=PickJob("1,2,3",D2)
where D2 points to is the previous job
I have an Excel worksheet with the following format:
Club A Total: ## Club B Total: ## Club C Total: ##
Account Placement Account Placement Account Placement
Value: ## Value: ## Value: ##
Account Placement
Value: ##
Club D Total: ## Club E Total: ## Club F Total: ##
Account Placement Account Placement Account Placement
Value: ## Value: ## Value: ##
Account Placement
Value: ##
Account Placement
Value: ##
For any club, they may have more than one account placement added later on, aligned to respective column as above. My objective is to calculate the Total for each club, which will automatically account for all Account Placement under a club, with the calculation goes as:
Eg. Total of Club B = Value of Account Placement 1 + Value of Account Placement 2 + ...
Same goes with other clubs. I have managed to locate each club and the value of first account using the following code:
Dim ra As Range
For Each ra In ActiveSheet.UsedRange
If InStr(1, ra.Text, "Account Placement") > 0 Then
accvalue = Cells(ra.Row + 1, ra.Column + 1).Value
End If
Next ra
The above code finds "Account Placement" horizontally, ie. it will get 1st value of Club A, then 1st value of Club B, then 1st value of Club C, then 2nd value of Club B, then 1st value of Club D etc. with respect to the above illustrated worksheet layout.
This make it hard to get the sum of Value for each Club. How do you get around this problem? Any help is appreciated.
Yes. The trick is to scan top-down, not left-to-right:
Option Explicit
Sub GetAllTotals2()
Dim dict
Set dict = CreateObject("Scripting.Dictionary")
Dim c As Range, UL As Range
Dim ID As String, nextID As String
Dim lastcol As Long, lastrow As Long, v As Long
With ActiveSheet.UsedRange
Set UL = .Cells(1, 1)
Set c = .Cells(1, 1)
lastcol = UL.Column + .Columns.Count
lastrow = UL.Row + .Rows.Count
End With
ID = ""
While c.Column < lastcol
Set c = Cells(UL.Row, c.Column + 1) ' top of column
'check if column empty
If c.End(xlDown).Row < lastrow Then
' scan "value" column for values; check for ID change!
While c.Row <= lastrow
If Left(c.Text, 5) = "value" Then
v = c.Offset(0, 1).Value
nextID = c.Offset(-2, -1)
' may check nextID, needs to be "Club x"...
If nextID <> "" Then ID = nextID ' ID changed
If dict.Exists(ID) Then
dict(ID) = dict(ID) + v
Else
dict.Add ID, v
End If
Set c = c.Offset(2, 0) ' skip next 2
End If
Set c = c.Offset(1, 0) ' row-wise
Wend
End If
Wend
' show
Dim key
For Each key In dict
Debug.Print key & " " & (dict(key))
Next key
End Sub
Using while loops is not optimal in regard to performance. The code shown already skips empty columns as a start. I thank user1274820 for the dictionary code which fits perfectly for this task.
edit:
With working code I thought about optimizations. Scanning all used cells (plus backtracking) leads to the worst possible performance. The following code works by scanning columns top-down only if it contains the "value" keyword which is checked by simply counting it. Furthermore, the cell pointer is not incremented by one but jumps to the next non-empty cell.
Sub GetAllTotals3()
Const keyword As String = "value:" ' got to be EXACT
Dim dict
Set dict = CreateObject("Scripting.Dictionary")
Dim c As Range, UL As Range
Dim ID As String, nextID As String
Dim lastcol As Long, lastrow As Long, v As Long
With ActiveSheet.UsedRange
Set UL = .Cells(1, 1)
Set c = .Cells(1, 1)
lastcol = UL.Column + .Columns.Count
lastrow = UL.Row + .Rows.Count
End With
ID = ""
While c.Column < lastcol
' check if column not empty
If WorksheetFunction.CountIf(c.EntireColumn, keyword) > 0 Then
' scan "value" column for keyword; check for ID change!
While c.Row <= lastrow
If c.Text = keyword Then
v = c.Offset(0, 1).Value
nextID = c.Offset(-2, -1)
' may check nextID, needs to be "Club x"...
If nextID <> "" Then ID = nextID ' ID changed
If dict.Exists(ID) Then
dict(ID) = dict(ID) + v
Else
dict.Add ID, v
End If
End If
' optim.: jump down to next filled cell
Set c = c.End(xlDown)
Wend
End If
' go right to next column, start at top
Set c = Cells(UL.Row, c.Column) ' top of column
Set c = c.End(xlToRight) ' optim.: jump right to next filled cell
Wend
' show
Dim key
For Each key In dict
Debug.Print key & ": " & (dict(key))
Next key
End Sub
Based on #user1274820's answer, I made a little adjustment.
Sub GetAllTotals()
Dim dict
Set dict = CreateObject("Scripting.Dictionary")
Dim ra As Range
Dim rollback As Integer 'Additional variable
For Each ra In ActiveSheet.UsedRange
If InStr(1, ra.Text, "Account Placement") > 0 Then
rollback = -1
'Rolling back number of rows to locate the Club ID
Do Until ra.Offset(rollback,-1).Value <> ""
rollback = rollback -1
Loop
With ra.Offset(rollback, -1)
If dict.Exists(.Value) Then
dict(.Value) = dict(.Value) + ra.Offset(1, 1).Value
Else
dict.Add .Value, ra.Offset(1, 1).Value
End If
End With
End If
Next ra
Dim c
For Each c In dict
Debug.Print c & " " & (dict(c))
Next c
End Sub
Like magic, everything fall perfectly into place.
I know I'm doing this wrong, I can't quite figure out the nomenclature for VBA. Basically, I want to copy the format, data and font from the cell above a cell if two conditions are met. To be exact, I want Z8 to copy format, data and font from Z7 if and only if Z8 is empty and S8 has information in it. Otherwise Z8 stays that way. And I want to do it for a specific range.
I would prefer not to use SET since I want to use other macros and I don't want range to be permanently set.
Sub ZFillTest()
Dim i As Integer
Dim k As Integer
Dim rng As Range
i = 0
k = 0
i = i + 4
k = k + 4
rng = ("Z5:Z200")
For Each cell In rng
If cell.Offset(k, 8).Value <> "" And cell(k, Z + i).Value = "" Then
cell(k, Z + i).Value = cell(k, Z + i - 1).Value
i = i + 1
k = k + 1
End If
Next
End Sub
Set is required to instantiate an object. You need to create a Range object and loop through it, to do that you have to use Set. That's not to say you can't set it to something different at a later stage.
Have a try with the code below:
Sub ZFillTest()
Dim rng As Range, r As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("Z5:Z200")
For Each r In rng
If r.Value = vbNullString And r.Offset(0, -7).Value <> vbNullString Then
r.Offset(-1, 0).Copy Destination:=r
r.Value = r.Value 'if you don't want formulas copied over
End If
Next r
End Sub
I have non-microsoft files that have look along the lines of:
>gibberish that changes
AAARRGGGHHHH
Now, I have a code to make a new .xlsx file out of this to split using Trying to convert files while keeping the old name.
However, I would like the "A2" cell contents to split with each indivual letter being assigned a cell and then have the former contents deleted. I don't mind if this ends up in A3 till AZ.
Thus, the above example I would like to transform to make it look like:
>gibberish that changes
A A A R R G G G H H H H
To clarify "Gibberish that changes" is not a constant it changes per file I have what is denoted here. Same holds true for the second line.
Based on Split cell string into individual cells
I tried this code:
Dim sVar1 as string
Dim sVar2 as string
I = InStr(1, strX, "A" & "R" & "G" & "H")
sVar1 = mid(strX, 1, I)
sVar2 = mid(strx,i+1)
However, this yields no results. It does not cause the Macro to fail (as I get no error message and the rest of the macro works (changing a file into another format and altering the name), but it doesn't do anything. I would like to use the string as the files constantly change in contents and order in cell A2.
I also have no true delimiter as things like ARRGHHHH is written as one word, is that causing the issue?
my 0.02 with Character object
Sub main()
With Range("A2")
For i = 1 To Len(.Value)
.Offset(, i) = .Characters(i, 1).Text
Next i
End With
End Sub
This will parse A2 into its characters and place the characters next to A2, each in its own cell:
Sub dural()
With Range("A2")
v = .Value
L = Len(v)
For i = 1 To L
.Offset(0, i).Value = Mid(v, i, 1)
Next i
End With
End Sub
EDIT#1:
This will handle both a range of input cells and the clearing of the original input data. Before:
The new macro:
Sub dural2()
Dim rng As Range, r As Range, v As Variant
Dim L As Long, i As Long
Set rng = Range("A2:A40")
For Each r In rng
v = r.Value
L = Len(v)
For i = 1 To L
r.Offset(0, i - 1).Value = Mid(v, i, 1)
Next i
Next r
End Sub
The result:
Would this be helpful at all?
Sub Test()
Dim i As Integer
Dim num As Integer
num = Len(Range("A1"))
For i = 1 To num
Debug.Print Mid(Range("A1"), i, 1)
Next
End Sub
Try this.
Sub dural()
With Range("A2")
v = .Value
L = Len(v)
For i = 0 To L - 1
If i = 0 Then
.Offset(0, i).Value = Left(v, 1)
Else
.Offset(0, i).Value = Mid(v, i, 1)
End If
Next i
End With
End Sub
Input
output