I am working on an Inventory workbook that has the inventory in one sheet and another sheet where I can scan barcode into and activate a macro to update the inventory sheet.
The goal is to read each cell in a column that has a value and then find the matching value in the other sheet and update the count by using the sum of the corresponding count values.
The VBA code I have so far updates the first item on the list, but just continues to update it endlessly. I am not sure what the best approach is and looking for a better route to update it in an efficient manner.
This is what I have so far
`Sub Inventory_Update()
Dim i As Integer
Dim b As Integer
i = 2
Do While Cells(i, "D").Value <> ""
If Cells(i, "D").Value <> "" Then
b = 1
Do While b < 346
If Sheet1.Cells(b, "B").Value = Cells(i, "D").Value Then
Sheet1.Cells(b, "C").Value = Sheet1.Cells(b, "C").Value + Cells(i, "F").Value
Else
b = b + 1
Loop
i = i + 1
End If
Loop
End Sub
`
Like this - a For Next loop is better for b
Sub Inventory_Update()
Dim i As Long, b As Long, wsInv As Worksheet, wsEntry As Worksheet
Set wsEntry = ThisWorkbook.Worksheets("Entry") 'for example
Set wsInv = ThisWorkbook.Worksheets("Inventory") 'or Sheet1
i = 2
'use a worksheet reference whenver you reference a range
Do While Len(wsEntry.Cells(i, "D").Value) > 0
For b = 1 To 346
If wsInv.Cells(b, "B") = wsEntry.Cells(i, "D").Value Then
With wsInv.Cells(b, "C")
.Value = .Value + wsEntry.Cells(i, "F").Value
End With
End If
Next b
i = i + 1
Loop
End Sub
I've written a macro that structures a lot of data and saving me for manual punching of numbers etc. The macro is written in stages were each part have been tested isolated and then integrated in loops or to the main code it self - this way each piece of code is tested so it functions accordingly to my intentions.
The goal for this part of code is to cycle through each row in the sheet, if the value of column 9, row I is different from the column 9, row I-1, then it will insert a new row (sum row). This action will be preformed in each worksheet, hence nested loop. When I wrote this macro isolated, without nesting loops, it functioned well.
Edit: To clearify, the code insert a row if and only if Cells(I, PrGr) = Cells(I - 1, PrGr) are unequal. Therefore I ask if they are the same, if they are so, do nothing - else, insert a row (i.e. Cells(I, PrGr) = Cells(I - 1, PrGr) are not equal.)
Running it in a nested loop causes a Run Time Error 13, type mismatch on the line with "If Cells(I, PrGr) = Cells(I - 1, PrGr) Then". In debugger, when I force it to continue, it does what it is supposed to do - creating the sum rows for in every sheet. This happens regardless of which sheet I set as the starting sheet.
I've tried to change the logic of the loop by testing with For Each ws In This.. and with the logic I have now For J = 1 to WS_ant. Both causes the error. I also searched around for clues, but non has come up with any solution appropriate for this problem.
Does someone have a clue to what is happening here, and how to fix it?
The code:
Sub OI_SJ()
'Selects the first sheet
Sheets(1).Activate
'Loop through sheets
Dim J As Integer
Dim WS_ant As Integer
Dim starting_ws As Worksheet
Set starting_ws = ActiveSheet 'remember which worksheet is active in the beginning
WS_ant = ThisWorkbook.Worksheets.Count
For J = 1 To WS_ant
ThisWorkbook.Worksheets(J).Activate
'If sheet = GRL, then terminate
If ThisWorkbook.Worksheets(J).Name = "LL - Sv" Or ThisWorkbook.Worksheets(J).Name = "RM - Sv" Then
'do something later
ElseIf ThisWorkbook.Worksheets(J).Name = "GRL" Then GoTo Term5
Else
Dim I As Integer
Dim PrGr As Long
PrGr = 9
Set aktivtark = ThisWorkbook.Worksheets(J)
With aktivtark
sistekolonne = aktivtark.Cells(1, .Columns.Count).End(xlToLeft).Column
sisterad = aktivtark.Cells(.Rows.Count, "A").End(xlUp).Row
End With
Application.CutCopyMode = False
Application.ScreenUpdating = False
With aktivtark.Range("A6", Cells(sisterad, sistekolonne))
.RowHeight = 15
End With
Rows(1).RowHeight = 24
For I = 6 To sisterad + 153
If Cells(I, PrGr) = Cells(I - 1, PrGr) Then
ElseIf Cells(I, PrGr) = "PrGr" Then
Else
Rows(I).EntireRow.Insert
Cells(I, 12) = "SUM " & Cells(I - 1, PrGr).Value
Cells(I, 33).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Cells(I, 34).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Cells(I, 35).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Cells(I, 36).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Cells(I, 37).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Cells(I, 38).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Cells(I, 39).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Cells(I, 40).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Cells(I, 41).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Cells(I, 42).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Cells(I, 43).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Cells(I, 44).Formula = "=SUMIF(R7C9:R1500C9,MID(RC12,5,255),R7C:R1500C)"
Rows(I).RowHeight = 17.25
I = I + 1
End If
Next
Application.CutCopyMode = True
Application.ScreenUpdating = True
End If
Cycle:
Next
Term5:
starting_ws.Activate 'activate the worksheet that was originally active
End Sub
With the insight from Vitaliy Prushak's post, I've changed that bit of code from If Cells(I, PrGr) = Cells(I - 1, PrGr) Then to If Cells(I, PrGr).Text = Cells(I - 1, PrGr).Text Then, since the cells contain text. This pushed the problem further down in the code, but it was solved with the same solution.
The macro now runs as it should, thanks for the help.
I need to search and to replace a specific part of a string in an Excel sheet.
Here is my code and I don't know how I can exactly search this part in each Cell.value.
my_new_string = "abc"
For each objSheet1 in objworkbook2.sheets
If objSheet1.Name = "Name1" Then
LastRow = objsheet1.UsedRange.Rows.Count + objsheet1.UsedRange.Row - 1
For i = 1 To LastRow Step 1
For j = 1 To 15 Step 1
If objExcel1.Cells(i, j).value = "xyz" Then 'Here I have to check if the Cell value contains xyz and to replace it by **my_new_string**
End if
Next
Next
End If
Next
Any help please ?
Thank you all,
this is working fine for me.
For Each objsheet1 In objworkbook2.Sheets
With objsheet1
If .Name = "BatchRun" Then
On error resume next
For i = 1 To 15 Step 1
For j = 1 To 10 Step 1
If InStr(1, .Cells(i, j).Value, my_old_string) > 0 Then
.Cells(i, j).Value = Replace(.Cells(i, j).Value, my_old_string, my_new_string)
End If
Next
Next
End If
End with
Next
I changed your method for finding the last row to one that is much more reliable.
Also you used 2 different objects to describe the same sheet, so I fixed it! ;)
Finally, you just need to use Replace method that will do the job perfectly fine, without need to test if the string is present with Instr (use it if you anything else to do if the old_string is detected)
Const my_old_string = "xyz"
Const my_new_string = "abc"
Const xlPart = 2
Const xlFormulas = -4123
Const xlByRows = 1
Const xlPrevious = 2
For Each objsheet1 In objworkbook2.Sheets
With objsheet1
If .Name = "Name1" Then
LastRow = .Cells.Find("*",.Range("A1"),xlPart,xlFormulas,xlByRows,xlPrevious,False).Row
For i = 1 To LastRow Step 1
For j = 1 To 15 Step 1
.Cells(i, j).Value = Replace(.Cells(i, j).Value, my_old_string, my_new_string)
' If InStr(1, .Cells(i, j).Value, my_old_string) Then
' .Cells(i, j).Value = Replace(.Cells(i, j).Value, my_old_string, my_new_string)
' End If
Next
Next
End If
End With
Next
My code copies a text from a cell in Matrix 1 to all the cells that meet my criteria in Matrix 2. But I want it to copy it only to the first cell that meets my critiria in Matrix 2 and then stop.
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
For j = 2 To 2
For i = 21 To 21
If Cells(i, j).Value > 0 Then
Cells(i, j).Value = Cells(i, j).Value - 1
Cells(i, j).Offset(0, -1).Select
End If
'as it says - for EACH - so it copies in aLL the cells'
'I can't Change the range though, cause there will come a Loop eventually'
For Each cell In Range("a1:aap15")
If cell.Interior.ColorIndex = 6 Then
If cell.Value = "" Then
cell.Value = ActiveCell.Value
End If
End If
Next
Next
Next
End Sub
You can use the Exit For command to exit a for loop. It looks like you want to add it here:
If cell.Interior.ColorIndex = 6 Then
If cell.Value = "" Then
cell.Value = ActiveCell.Value
Exit For
End If
End If
Note: not tested. Let me know if you have any problems
I'm trying to work out how to write a Macro to replace the current Excel formula I'm using. I've tried experimenting with cell values and offsets but my knowledge of VBA is minimal. What I need it to do is to turn a single column list like this:
Cell 1
Cell 2
Cell 3
Cell 4
Cell 5
Cell 6
Into a two-column list like this:
Cell 1 Cell 2
Cell 3 Cell 4
Cell 5 Cell 6
I feel as if it should be pretty simple to achieve, but I want to avoid blank spaces and a loop will probably be required as the length of the list is likely to change each time the macro is run. Can anybody help?
I managed to work out how to do it:
Sub splitColumn()
Range("A1").Select
Do
ActiveCell.Offset(1, 0).Select
If IsEmpty(ActiveCell.Offset(-1, 1)) Then
ActiveCell.Offset(-1, 1).Value = ActiveCell
ActiveCell.EntireRow.Delete
End If
Loop Until IsEmpty(ActiveCell)
End Sub
May be you can try with the following code:
But its a bit too long...I think it may help you in providing some ideas...
Sub Splitting()
Dim i, j, k, l As Integer
RowCount = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
For i = 1 To RowCount Step 2
For j = 1 To 1
Cells(i, j + 1).Value = Cells(i, j).Value
Cells(i, j + 2).Value = Cells(i + 1, j).Value
Next j
Next i
Call Removeblanks
End Sub
Sub Removeblanks()
RowCount = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
For i = 1 To RowCount
For j = 1 To 1
If (Cells(i, j + 1).Value = "") Then
Cells(i, j + 1).Delete
Cells(i, j + 2).Delete
End If
Next j
Next i
End Sub