I am new at vba and i want to make a macro for my daily routine. I successfully manage big part of them with your helps here, but i stuck a section.
What i want : I have a analysis file, and it comes with months, beginning of code i am asking how many months have in file and want to know which of them.
Sub Makro2()
howmanymonths= Application.InputBox(prompt:=ActiveSheet.Name & " how many months?", Type:=1)
For first = 1 To howmanymonths
nay = Application.InputBox(prompt:=ActiveSheet.Name & " First?", Type:=1)
Next first
End Sub
For example, there are totally 3 months and i answered first "3",then next question i replyed "7" so nay = 7, but when its in loop next will be "8" and "9"
but how i can create nay1, nay2,nay3 or till what last months.
Maybe a better solution? Please help me.
Here is the example for storing multiple data in dictionary and retrieve them using their key.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
howmanymonths = Application.InputBox(prompt:=ActiveSheet.Name & " how many months?", Type:=1)
For first = 1 To howmanymonths
'Key is nay + numberindex
dict.Add "nay" & CStr(first), Application.InputBox(prompt:=ActiveSheet.Name & " First?", Type:=1)
Next first
MsgBox dict("nay1")
MsgBox dict("nay2")
MsgBox dict("nay3")
You cannot create new variables in a sub, while running the sub. And in general you do not need to. If you do not know how many units do you need, you may use an Array() or List() and add elements to them:
Sub TestMe()
Dim howManyMonths As Long
howManyMonths = Application.InputBox(prompt:=ActiveSheet.Name & Months count?",Type:=1)
Dim firstMonth As Long
firstMonth = Application.InputBox(prompt:=ActiveSheet.Name & " First?", Type:=1)
Dim someArray() As Long
Dim cnt As Long
ReDim someArray(howManyMonths - 1)
For cnt = LBound(someArray) To UBound(someArray)
someArray(cnt) = firstMonth + cnt
Next cnt
For cnt = LBound(someArray) To UBound(someArray)
MsgBox someArray(cnt)
Next cnt
End Sub
Related
So my problem is that for previous users who are keeping track of inventory they have labeled items with a ID of example: ABC1234 - ABC1244 but the problem is that when we keep track of our items we need each and ever individual item to be properly accounted for as each item has a unique ID that we track.
So for the past half a year we have been slowly filling in everything and since there are tons of other information in the row that is repeated I was wondering if there was a way to write a VBA macro to expand and insert these rows of data.
So from this
ID
Description
ABC1234 - ABC1237
Screw type A
to this
ID
Description
ABC1234
Screw type A
ABC1235
Screw type A
ABC1236
Screw type A
ABC1237
Screw type A
I have tried using the record macro functions but its not dynamic which is not what I want as the Database can change over time with the influx of new items so I hope there is a way to dynamically complete this process. If anyone knows a solution please help have been banging my head against a wall for awhile now :'D
not sure if this is what you are looking for.
I am assuming your ABC is always the same, the only thing that is changing is the last 4 number.
Sub Formatting()
Dim xlwrks As Object
Dim xlrng As Object
Dim xlcell As Object
Dim lowerlimit As Integer, upperlimit As Integer
Set xlwrks = ThisWorkbook.Sheets("Sheet1")
Set xlrng = xlwrks.Range("A2", xlwrks.Range("A" & Rows.Count).End(xlUp).Address) 'from A2 to last cell in column A
For Each xlcell In xlrng 'iterate ech cell from xlrng
'e.g splitting this into array of string with the delimiter " - " by using split
'which will look something like "ABC1234", "ABC1237" for A2 and "ABC1238", "ABC1242" for A3
'next we only the last 4 number, by using right
lowerlimit = Right(Split(xlcell.Value2, " - ")(0), 4)
upperlimit = Right(Split(xlcell.Value2, " - ")(1), 4)
Do Until lowerlimit = upperlimit + 1
xlwrks.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value2 = "ABC" & lowerlimit
xlwrks.Range("D" & Rows.Count).End(xlUp).Offset(0, 1).Value2 = xlcell.Offset(0, 1).Value2
lowerlimit = lowerlimit + 1
Loop
Next xlcell
End Sub
adding on to the requirement, as mentioned, need to monitor the trend. wrote something to check for the trend instead of manually eyeball the trend. Do note with this, the run time will be longer, because it will loop through each cell to look at the array, it will also loop through each array to look at each character. hope this help happy coding!~~
Dim xlwrks As Object
Dim xlrng As Object
Dim xlcell As Object
Dim lowerlimit As Long, upperlimit As Long
Dim charpos As Integer, characters As String, ID As String
Set xlwrks = ThisWorkbook.Sheets("Sheet1")
Set xlrng = xlwrks.Range("A2", xlwrks.Range("A" & Rows.Count).End(xlUp).Address) 'from A2 to last cell in column A
For Each xlcell In xlrng 'iterate ech cell from xlrng
'e.g splitting this into array of string with the delimiter " - " by using split
'which will look something like "ABC1234", "ABC1237" for A2 and "ABC1238", "ABC1242" for A3
'next we only the last 4 number, by using right
characters = Split(xlcell.Value2, " - ")(0)
For charpos = 1 To Len(characters)
If Not IsNumeric(Mid(characters, charpos, 1)) Then
ID = ID & Mid(characters, charpos, 1)
Else
Exit For
End If
Next charpos
For charpos = 1 To Len(characters)
If IsNumeric(Mid(characters, charpos, 1)) Then
lowerlimit = CStr(lowerlimit) & CStr(Mid(characters, charpos, 1))
End If
Next charpos
characters = Split(xlcell.Value2, " - ")(1)
For charpos = 1 To Len(characters)
If IsNumeric(Mid(characters, charpos, 1)) Then
upperlimit = CStr(upperlimit) & CStr(Mid(characters, charpos, 1))
End If
Next charpos
Do Until lowerlimit = upperlimit + 1
xlwrks.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value2 = ID & lowerlimit
xlwrks.Range("D" & Rows.Count).End(xlUp).Offset(0, 1).Value2 = xlcell.Offset(0, 1).Value2
lowerlimit = lowerlimit + 1
Loop
lowerlimit = 0
upperlimit = 0
ID = ""
Next xlcell
Honestly, I would not do this with VBA inside the spreadsheet. I would write a separate piece of VB or VBScript that reads the existing spreadsheet and produces a new altered copy of it.
When it reads a line in the original spreadsheet with just "ABC1234", it just copies that line to the new spreadsheet. When it reads a line that contains "ABC1234 - ABC1237", it recognizes the pattern and figures out how many lines it needs to generate in the new spreadsheet. In this case, it will generate four lines: one line for ABC1234, one line for ABC1235, one line for ABC1236, and one line for ABC1237.
I think this approach will be easier to deal with than a VBA script inside the spreadsheet. You will run it once, check the new spreadsheet, then rename the old one for safe-keeping, and rename the new one to give it the original sheet's name.
I have 20 cases. For every row in my sheet, I have a cell that assigns related case numbers to it. A row could have multiple case numbers assigned to it in that cell (Example: 1,2,11,12)
I am writing a code to copy all the rows that have Case number 1 assigned to them, copy them someplace else..
and then go to case number 2 and repeat the same..
This is what I am using:
For CaseNumbers = 1 To 20
For i = Row1 To RowLast
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
COPY AND PASTE CODE
End If
Next
Next
The problem I am facing is, the code considers case number 11 as case number 1 too (since it has the digit 1).
This is the first time I am writing a VBA code and I have no background in this.
Can someone please advise on better way of doing this? Should I assign a checklist instead to each row?
All I want to do is find all the rows that have Case number 1 assigned, copy them.. then find all the rows that have Case 2 assigned, copy them.. and so on.
Please help.
You can use a function to do the test
Public Function isCaseNumberIncluded(ByVal caseToCheck As Long, ByVal caseNumbers As String) As Boolean
'add , to make all values distinct
caseNumbers = "," & caseNumbers & ","
Dim strCaseToCheck As String
strCaseToCheck = "," & caseToCheck & ","
If InStr(1, caseNumbers, strCaseToCheck) > 0 Then
isCaseNumberIncluded = True
End If
End Function
You would call this function within your main code like this:
Dim caseNumber As Long 'I removed the s - as this could be misleading in my eyes
For caseNumber = 1 To 20
For i = Row1 To RowLast
If isCaseNumberIncluded(caseNumber, Range(CaseNoCell & i).Value) Then
COPY AND PASTE CODE
End If
Next
Next
Using a separate function to run the test has two advantages:
your code gets more readable, ie you know from reading the functions name what the result should be - without reading the whole code how to do it :-)
you can re-use this code propably at another place
Or you can test the function first:
Public Sub test_isCaseNumberIncluded()
Debug.Print isCaseNumberIncluded(1, "1,2,11,12"), "Should be true"
Debug.Print isCaseNumberIncluded(1, "2,11,12"), "Should be false"
Debug.Print isCaseNumberIncluded(11, "1,2,11,12"), "Should be true"
Debug.Print isCaseNumberIncluded(11, "1,2,12"), "Should be false"
End Sub
Well, you are working with this piece of code:
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
This checks against 1,, 12,, ..., but obviously it won't cover the last entry so that's something you'll need to add. And you have the problem that 11, gets treated as 1,.
In a similar way you can use this piece of code:
If InStr(1, Range(CaseNoCell & i).Value, "," & CaseNumbers & ",") Then
This checks against ,1,, ,12,, ... so it will solve your error, but obviously it won't cover the last and the first entry so that's something you'll need to add.
This is something that should be encapsulated in a function rather than being done in line. The method provided in VBA for tokenising a string is 'Split'.
You could wite a function that checks tokens 1 by 1, or which compile a collection of the tokens which then uses a built checking method of the collection to determine if the specified token is present or not.
In this specific case I've chosen to use the collection method. The specific object for the collection is the ArrayList (but a Scripting.Dictionary is also possible). The function contains checks for zero length strings and allows the seperator to be specified if it isn't a comma.
Option Explicit
Function FindToken(ByVal ipToken As String, ByVal ipTokenList As String, Optional ByVal ipSeparator As String = ",") As Boolean
' Guard against ipSeparator being vbnullstring
Dim mySeparator As String
mySeparator = IIf(VBA.Len(ipSeparator) = 0, ",", ipSeparator)
'Raise an error if ipToken or ipTokenList are empty strings
If VBA.Len(ipToken) = 0 Or VBA.Len(ipTokenList) = 0 Then
Err.Raise 17, "Empty string error"
End If
'Convert the token list to tokens
Dim myTokens As Variant
myTokens = VBA.Split(ipTokenList, mySeparator)
' Put the tokens in an ArrayList so we can use the contains method
' no point is doing early binding as arraylist doesn't provide intellisense
Dim myAL As Object
Set myAL = CreateObject("System.Collections.ArrayList")
Dim myItem As Variant
For Each myItem In myTokens
' Trim just in case there are spaces
myAL.Add VBA.Trim(myItem)
Next
'Finally test if the Token exists in the token list
Find = myAL.contains(VBA.Trim(ipToken))
End Function
This means that your code
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
can now be rewritten as
If FindToken(CStr(CaseNUmbers), Range(CaseNoCell & cstr(i)).Value) Then
Identify Criteria Rows
Option Explicit
Sub Test()
Const WordSeparator As String = ","
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim CaseNumber As Long
Dim i As Long
Dim cValue As Variant
Dim cString() As String
For CaseNumber = 1 To 20
For i = Row1 To RowLast
cValue = CStr(ws.Range(CaseNoCell & i).Value)
If Len(cValue) > 0 Then
cString = Split(cValue, WordSeparator)
If IsNumeric(Application.Match( _
CStr(CaseNumber), cString, 0)) Then
' CopyAndPasteCode CaseNumber
Debug.Print "Case " & CaseNumber & ": " & "Row " & i
End If
End If
Next i
Next CaseNumber
End Sub
This question already exists:
VBA delete entire row with number (variable of For loop)
Closed 2 years ago.
thank you all in advance for your help. I'm not an advanced coder at all but in some way managed to make to following code work, except one really basic thing.I'm struggling with a very basic issue namely the actual deleting of 1 row every time the condition is not getting fulfilled. And the number of the row should be taken from a FOR loop. The coordinate in which the FOR loop is currently positioned should be reflected by S.Row but as I showed below, I've been trying multiple ways of deleting it and I get always an error with "Run-time error '1004': Application-defined or object-defined error" It's driving me crazy, please help. ONE MORE TIME THANK YOU ALL:
Public Sub Optionfilter()
Dim StrikeD As Date
Dim RefD As Date
Dim StrikeP As Integer
Dim S As Range
Dim R As Range
Dim XVAR As Integer
Dim Intervall As String
Dim Number As Integer
Dim TotalRow As Integer
Dim L As Integer
XVAR = 5
Intervall = ThisWorkbook.Worksheets("Data").Range("I2").Value
Debug.Print Intervall
Number = ThisWorkbook.Worksheets("Data").Range("G2").Value
Debug.Print Number
Debug.Print ThisWorkbook.Worksheets("Data").Range("G2").Address
Debug.Print "-----------------------------------------"
XP:
For Each S In ThisWorkbook.Worksheets("Data").Range("J6:J" & ThisWorkbook.Worksheets("Data").UsedRange.SpecialCells(xlCellTypeLastCell).Row)
Debug.Print S.Address & " in the Calc Loop"
Debug.Print ThisWorkbook.Worksheets("Data").UsedRange.Cells(S.Row, S.Column - 1).Value
Debug.Print ThisWorkbook.Worksheets("Data").UsedRange.Cells(S.Row, S.Column - 1).Address
StrikeD = ThisWorkbook.Worksheets("Data").UsedRange.Cells(S.Row, S.Column - 1).Value
Debug.Print StrikeD
Debug.Print "-----------------------------------------"
RefD = ThisWorkbook.Worksheets("Data").Range("E2").Value
Debug.Print RefD
RefD = DateAdd(Intervall, Number, RefD)
Debug.Print RefD
DIFFRAW = Abs(StrikeD - RefD)
Debug.Print DIFFRAW
ThisWorkbook.Worksheets("Data").UsedRange.Cells(S.Row, S.Column + 1).Value = DIFFRAW
If ThisWorkbook.Worksheets("Data").UsedRange.Cells(S.Row, S.Column + 1).Value > XVAR Then
Debug.Print S.Row
L = S.Row
'This code below is not deleting anything for some reason it's just getting executed but no row disappear/delete
Rows(S.Row).EntireRow.Delete
'This code below is also not deleting anything for some reason it's just getting executed but no row disappear/delete
Range("J" & S.Row).EntireRow.Delete
'This code below is giving me the mentioned ERROR
'ThisWorkbook.Worksheets("Data").Rows(L).Delete
'OR Run-time error 438
ThisWorkbook.Worksheets("Data").S.EntireRow.Delete
'OR
Range("A" & S.Row).EntireRow.Delete
'OR
ThisWorkbook.Worksheets("Data").Rows("S.Row").Delete
'OR
ThisWorkbook.Worksheets("Data").Range(S, 1).EntireRow.Delete
Else
End If
Next S
TotalRow = ActiveSheet.UsedRange.Rows.Count
Debug.Print TotalRow
Debug.Print ThisWorkbook.Worksheets("Data").UsedRange.Cells(S.Row, S.Column).Address
Debug.Print ThisWorkbook.Worksheets("Data").UsedRange.Cells(S.Row, S.Column).Value
Sheets.Add After:=Worksheets("Data") 'After we deleted the old datasheet, we now insert a new (empty) one
Sheets(3).Name = "TEMP" 'and rename it instead of the defaultname to
If TotalRow <= 10 Then ' And ThisWorkbook.Worksheets("Data").UsedRange.Cells(S.Row, S.Column).Value > 0 Then
For Each R In ThisWorkbook.Worksheets("Data").Range("J6:J" & ThisWorkbook.Worksheets("Data").UsedRange.SpecialCells(xlCellTypeLastCell).Row)
ThisWorkbook.Worksheets("Data").UsedRange.Cells(S.Row).Copy
ThisWorkbook.Worksheets("Temp").Cells(j, 2).PasteSpecial xlPasteValues
j = j + 1 'This is a controlvariabel to write the copied cell everytime in a new row
Next R
Else
XVAR = XVAR - 1
GoTo XP
End If
End Sub
'S eine erste Position zu ordnen
'zusätzlichen Goto einfpügen falls 0 resultate sind und schleife mit Prioritisierung der ergebnisse -->besser davor als danahc usw.
' Debug.Print ActiveSheet.Cells(S.Row, S.Column + 7).Value
's.Value = Replace(s.Value, ",", "") 'delete the ","
' If InStr(1, S, "S") > 0 Then 'The command InStr(1, s, "S") respond the place (position) where it found "S" in the cellstring
' '(s), for example: 1/5/3... basically it looks if in this cell the letter appears
' S.Value = Replace(S.Value, " ", "") 'If it has found an "S" in the cell value (for example in the portgolionumber
' '011 1044 S02) then it replaces all " " by "" and write the new value (0111044S02) in the cell
' End If 'Ends the if condition
I can't follow what you posted here but this addresses the core of your original question:
Dim i As Long, ws As Worksheet, XVAR As Long
Set ws = ThisWorkbook.Worksheets("Data")
'XVAR = '...something
For i = ws.Cells(Rows.Count, 10).End(xlUp).Row To 6 Step -1
If ws.Cells(i, 11).Value > XVAR Then
ws.Rows(i).Delete
End If
Next i
This may or may not be related to the issue you are having, but I'm writing as an answer to help with misunderstandings it looks like you are having.
Your variable S is a range. As such excel knows everything about that range when you set it. It knows it's value, it's row and column, the sheet in which it's contained, and the workbook in which that sheet is contained. All of your code where you qualify your S variable or pulling the row only to use it's Long value to refer to the same row... is superfluous at best and causing errors at worse.
For instance:
Rows(S.Row).EntireRow.Delete
You are literally saying "Grab the number representing the row in which this cell resides and in whatever worksheet is currently active (who knows what that is...?), delete the entire row that corrsponds to that number".
Instead:
S.EntireRow.Delete
Now it says "Delete the entire row in which the cell held in variable S resides".
As for your error:
ThisWorkbook.Worksheets("Data").S.EntireRow.Delete
This says "The cell in variable S, for which we already know which sheet and workbook it resides by the nature of the range object being held in this variable, (let me tell you regardless though) that's specifically in ThisWorkbook and the Worksheet called Data delete it's entire row."
Excel isn't down with this because you can't qualify a range object like this with a worksheet and workbook. It's already set and unchangeable. Range S is already 100% unchange-ably in Sheet "Data" and ThisWorkbook. Your attempt to tell excel this information again is just making excel angry.
Instead:
S.EntireRow.Delete
Which looks familiar.
thank you very much for the elaboration and the time you took for it. I really appreciate it, thank you. It makes all sense, but after copying your code ( S.EntireRow.Delete) into my syntax I receive always the same error stated here: https://qph.fs.quoracdn.net/main-qimg-0ea61a60a22c8fbbbf3e95c1b463b242
I am trying to get some text between two words from a column of similar data, so far I have:
Dim I As Integer
For I = 1 To 989
thisSTRING = Worksheets(1).Range("A" & I).Value
ref = Split(Split(thisSTRING, "RING ")(1), " EM")(0)
Worksheets(1).Range("B" & I).Value = ref
Next I
The problem I have is that not all text in the column is the same and when I reach such a point in the for loop I get an error message as there is either no "RING" or "EM", to avoid this I tried to use "on error resume next". This worked but it duplicates in the cells which had the errors. Is there any simple method for making this skip the cell/leave it blank instead of creating a duplicate?
Here's what I was thinking:
Sub PrintSplit()
Dim ws As Excel.Worksheet
Dim i As Long
Dim thisSTRING As String
Dim ref As String
Set ws = ThisWorkbook.Worksheets(1)
For i = 1 To 989
thisSTRING = ws.Range("A" & i).Value
If InStr(thisSTRING, "RING ") > 0 And InStr(thisSTRING, " EM") > 0 Then
ref = Split(Split(thisSTRING, "RING ")(1), " EM")(0)
ws.Range("B" & i).Value = ref
End If
Next i
End Sub
This assumes that you want a blank if either of the strings are missing. If you only wanted it if both strings are missing the logic would be different, but similar.
Note that I changed i to a Long which is a good practice, as it's the native type for whole numbers and will accommodate larger values. I also created a worksheet variable, just to make it a little more flexible, and to get Intellisense.
I am writing a custom sorting procedure for my Excel spreadsheet that has at least 3 worksheets. On first position I put the worksheet called "Summary", on second goes "Data" and the rest are worksheets whose names are dates ex "17.03.2011", "20.03.2011" etc. Those need to be sorted chronologically.
Here is what I have so far, the script stops with an "Object Required" error on line with the DateDiff() and I have no idea why:
After correcting the code below I am still having trouble in making the thing sort in the right order. Can anyone suggest a way to compare and move around the sheets?
Public Sub ssort()
sSummary.Move before:=Worksheets.Item(1)
sData.Move after:=sSummary
Dim i, n As Integer
Dim diff As Long
Dim current, other As Worksheet
For i = 1 To Worksheets.Count
Set current = Worksheets.Item(i)
If current.Name <> sData.Name And current.Name <> sSummary.Name Then
For n = i + 1 To Worksheets.Count
Set other = Worksheets.Item(n)
diff = DateDiff(DateInterval.day, Format(current.Name, "dd.mm.yyyy"), Format(other.Name, "dd.mm.yyyy"))
If diff > 0 Then
current.Move before:=other
Debug.Print "Moving " & current.Name & " before " & other.Name
ElseIf diff < 0 Then
current.Move after:=other
Debug.Print "Moving " & current.Name & " after " & other.Name
End If
Next n
End If
Next i
End Sub
I think I either don't understand DateDiff() or Format(), could anyone please shed some light on this?
After modifying code from an online example here http://www.vbaexpress.com/kb/getarticle.php?kb_id=72 to use the datediff for comparison, I came up with this solution which works as intended:
Sub sort2()
sSummary.Move before:=Worksheets.Item(1)
sData.Move after:=sSummary
Dim n As Integer
Dim M As Integer
Dim dsEnd, lowest As Integer
Dim dCurrent() As String
Dim dOther() As String
Dim diff As Long
dsStart = 3
dsEnd = Worksheets.Count
For M = dsStart To dsEnd
For n = M To dsEnd
If Worksheets(n).Name <> "Summary" And Worksheets(n).Name <> "Data" And Worksheets(M).Name <> "Summary" And Worksheets(M).Name <> "Data" Then
dCurrent = Split(CStr(Worksheets(n).Name), ".")
dOther = Split(CStr(Worksheets(M).Name), ".")
diff = DateDiff("d", DateSerial(dCurrent(2), dCurrent(1), dCurrent(0)), DateSerial(dOther(2), dOther(1), dOther(0)))
If diff > 0 Then
Worksheets(n).Move before:=Worksheets(M)
End If
End If
Next n
Next M
End Sub
The DateDiff function requires the two date arguments to be of Variant (Date) type. Instead you're giving it two String arguments, which is what the Format function returns.
You need to convert each of the Strings to Variant (Date). This can be done like this:
strDate = current.Name ' String: "20.03.2011"
aintDateElements = Split(strDate, ".") ' Array: {2001, 03, 20}
varDate = DateSerial(aintDateElements(2), aintDateElements(1),
aintDateElements(0)) ' Variant (Date)
There are other ways of doing this conversion, but I find that this is the way that least often gives unexpected results!
If you took this code off of the web, be aware that DateInterval isn't a native Excel object or a VBA object, it's a .Net object. You could just substitute "d" for "DateInterval.day".
diff = DateDiff("d", Format(current.Name, "dd.mm.yyyy"), _
Format(other.Name, "dd.mm.yyyy"))
If you're getting error messages in Format/Datediff calls, try split them into separated statements. You'll see where the problem lies.
Example:
dtStart = CDate(Format(current.Name, "dd.mm.yyyy"))
dtEnd = CDate(Format(other.Name, "dd.mm.yyyy"))
diff = DateDiff("d", dtStart, dtEnd)