I have managed to make it this far with my macro, but I cant figure out how to loop the macro to the next line. Any assistance would be greatly appreciated.
Here is the macro that I need looped:
Sub loopplannercomments()
'
' loopplannercomments Macro
' gather planner comments for each line
'
Range("I31").Select
Selection.Copy
Windows("BP Tool Notes for Missing Material 12.27.xlsm").Activate
ActiveSheet.PivotTables("PivotTable1").PivotFields("sod_part").ClearAllFilters
ActiveSheet.PivotTables("PivotTable1").PivotFields("sod_part").CurrentPage = _
"S166877 / 2"
Range("F10").Select
Selection.Copy
Range("G10").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("G10").Select
ActiveCell.Replace What:="( )", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("g15").Select
Selection.Copy
Range("H15").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("h15").Select
Application.CutCopyMode = False
Selection.Copy
Windows("SPV Schedule 1.13 LACERENZA REV1.xlsm").Activate
Range("O31").Select
ActiveSheet.Paste
End Sub
I have tried researching what different types of loop structures there are, and I am not sure which one I should use or how to implement said code string.
I have one sheet named Sheet3 and another are Sheet4. Sheet3: Column A Header is Product type, and Column B is their Quantity, Sheet4 has same column Header. Product Type and Quantity. But when I Run Below Macro in Sheet3, Sometime they add values correctly to
Sheet4 and sometime they doesn't work properly.
Sub Increase_Value()
Sheets("Sheet3").Select
Cells.Find(What:=Sheet4.Range("A2").Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Sheets("Sheet4").Select
Range("A2").Select
ActiveCell.Offset(0, 1).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
ActiveCell.Offset(0, 1).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _
False, Transpose:=False
Range("E10").Select
Sheets("Sheet3").Select
Cells.Find(What:=Sheet4.Range("A3").Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Sheets("Sheet4").Select
Range("A3").Select
ActiveCell.Offset(0, 1).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
ActiveCell.Offset(0, 1).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _
False, Transpose:=False
Range("E10").Select
Sheets("Sheet3").Select
Cells.Find(What:=Sheet4.Range("A4").Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Sheets("Sheet4").Select
Range("A4").Select
ActiveCell.Offset(0, 1).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
ActiveCell.Offset(0, 1).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _
False, Transpose:=False
Range("E10").Select
Sheets("Sheet4").Select
Range("A2:B4").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("A2").Select
ActiveWorkbook.Save
End Sub
For Example: If Sheet3 Range A3 = **Coca Cola**, And B3 = **20**, And When I rum the macro Increase_Value(), The VBA should find the value Coca Cola in Sheet4 Column A and if value found in row 10 (A10) then add value 20 from sheet3 Range B3 to sheet4 Range B10.
If B10 is 47 then after running the macro it should be 67.
Looks like you are trying to do something that a vlookup could solve easily? You can do vlookups in VBA as well
Below is the exact formula -
'''Application.WorksheetFunction.vlookup(lookup_value, table_array, col_index_num, range_lookup)'''
You can find more information on this here:
https://excelmacromastery.com/vba-vlookup/
Thanks,
I'm using this code, but columns with last row (A,B,K,L) fill in with 0 beyond the defined last row. Additionally, my transaction and type occasionally stop working, but if anyone sees what i'm doing wrong i'd love to learn so i don't have this issue again.
Sub test()
Dim lastRow As Long
lastRow = Cells(Rows.Count, 10).End(xlUp).Row
'delete blank columns
Range("W:W,U:U,S:S,Q:Q,O:O,M:M,K:K,I:I,G:G,E:E,C:C,A:A").Select
Range("A1").Activate
Selection.Delete Shift:=xlToLeft
'filter for blanks
Range("A:L").CurrentRegion.Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$L$1").AutoFilter Field:=10, Criteria1:="="
ActiveSheet.AutoFilter.Range.Offset(1, 0).Rows.SpecialCells(xlCellTypeVisible).Delete (xlShiftUp)
Selection.AutoFilter
'Trans
Columns("A:A").Select
Selection.NumberFormat = "General"
Range("A2:A" & lastRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Type
Columns("B:B").Select
Selection.NumberFormat = "General"
Range("B2:B" & lastRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
Columns("B:B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Debit
Range("K2:K" & lastRow).Select
'Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'credit
Range("L2:L" & lastRow).Select
'Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
So sorry for my English, just get you wrong 😆
Try to use cycle instead of replace.
Use Dim EmptCell as range once.
Dim EmptCell as range
For Each EmptCell in Range("youRange").Cells
If EmptCell.value = "" Then EmptCell.value = 0
Next EmptCell
And try to not to use selection. Work directly with a ranges, or use variables like you did with LastRow.
Small example below.
' Trans
Columns("A:A").NumberFormat = "General"
Range("A2:A" & lastRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
Columns("A:A").value = Columns("A:A").value
And I'm definitely recommend to change LastRow algorithm to this bulletproof one.
© https://stackoverflow.com/a/11169920/12882709
With Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastrow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lastrow = 1
End If
Sheets("MDCF").Select
Range("B6:B100").Select
Selection.Copy
Range("J6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Replace What:="10000", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("J6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("MDCF Fund").Select
Range("F7").Select
ActiveSheet.Paste
With Sheets("MDCF Fund")
Set FOUNDRANGE = .Columns("F:F").Find("*", After:=.Range("F81"), searchdirection:=xlPrevious,
LookIn:=xlValues)
If Not FOUNDRANGE Is Nothing Then LR1 = FOUNDRANGE.Row
End With
Range("F80:F" & LR1 + 1).Select
Selection.Clear
I am trying to delete the cells that are below last cell in new sheet but its not working if the cell range is same in both copy paste ranges. trying to find a way in which I will be able to delete only redundant cell that are above F80 and below the copied cell counts.
If you want to straight away delete all the data after F80 then the below code would work,
With Sheets("MDCF Fund")
LR1 = Range("F" & Rows.count).end(xlup).row
'If you want to keep the cells between the pasted data and F80 then just add the IF condition
If (LR1 > 80) Then
Range("F80:F" & LR1).Select
Selection.clear
end if
I am going to try to explain this as effectively as possible, so please bear with me.
I have various sheets called "Blasted" followed by a number 1 to x.
I want to loop through Column A of each sheet "Blasted" and find various strings within the columns. Once the value has been found, it must be copied to a sheet called "Blast List".
In the Sheet "Blast List", I have a cells in Column A with the same names as the sheets (Blasted 1 and so on) going down the column.
I have done the following code and managed to get Blasted 1 working, but want to make it more elegant and need help getting it to do all sheets called "Blasted"
Sub CopyBlastSheetData()
Dim e As String
Dim g As String
Dim h As String
Dim i As String
Dim j As String
Dim k As String
Dim l As String
Dim m As String
Dim n As String
Dim o As String
Dim p As String
Dim q As String
Dim r As String
Dim s As Long
Dim CStep As Long
Dim xCount As Integer
Dim ws As Worksheet
Dim ws1 As Worksheet
e = "PU"
g = "LINE TEST"
h = "EXTRA DETS"
i = "INTERMITTENT CONNECTION DETS"
j = "MISSING DETS"
k = "OUT OF ORDER DETS"
l = "INCOHERENT DETS"
m = "DELAY ERRORS DETS"
n = "CHARGE"
o = "ADDITIONAL MISSING DETS"
p = "LOW ENERGY DETS"
q = "ADDITIONAL INCOHERENT DETS"
r = "FIRE"
CStep = 1
For s = 1 To ActiveWorkbook.Sheets.Count
If InStr(1, Sheets(s).Name, "Blasted") > 0 Then xCount = xCount + 1
Next
While CStep < xCount
Do
Set ws = ThisWorkbook.Worksheets(CStr("Blasted " & CStep))
Set ws1 = ThisWorkbook.Worksheets("Blast List")
ws.Select
Range("A1").Select
Cells.Find(What:=e, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("E3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=g, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("G3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=h, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("H3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=i, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("I3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=j, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("J3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=k, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("K3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=l, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("L3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=m, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("M3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=n, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("N3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=o, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("O3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=p, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("P3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=q, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("Q3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws.Select
Range("A1").Select
Cells.Find(What:=r, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
ws1.Select
Range("R3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Wend
CStep = CStep + 1
Next
End Sub
The idea is to ultimately look at the name of the sheet in Blast List in Column A, Select the Sheet with the same name as the text in the cell ("Blasted 1"), find the strings (e to r in the code), copy the cell, paste the cell to the next open cell in the same row as the name of the sheet in the sheet called Blast List.
Once completed, loop to the next sheet (e.g "Blasted 2") and copy and paste again.
This must be done until there is no more sheets called Blasted
Also if the string being searched for is not found, it must put "No Event" in the correct cell in Blast List.
Please help
Hi I managed to find a way to do it using the entire weekend playing:
Heres the code I used:
Sub CopySingle()
Dim wsfr As Worksheet
Dim wsl As Worksheet
Dim BlNumber As String
Dim BSStep As Long
Dim SI As String
Dim Srng As Range
Dim Nrng As Range
Dim Rrng As Range
Dim Brng As Range
Dim Arng As Range
Application.ScreenUpdating = False
BSStep = 1
Set Rrng = ThisWorkbook.Worksheets("Blast List").Range("A3", Range("A3").End(xlDown))
Set Srng = ThisWorkbook.Worksheets("Blast List").Range("E1:Q1")
For Each Brng In Rrng.Cells
For Each Nrng In Srng.Cells
On Error Resume Next
SI = Nrng.Value
BlNumber = CStr("Blasted " & BSStep)
Set wsfr = ThisWorkbook.Worksheets(CStr(BlNumber))
Set wsl = ThisWorkbook.Worksheets("Blast List")
wsfr.Select
Range("A1").Select
Cells.Find(What:=SI, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
Sheets("Blast List").Select
Range("A1").Select
Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next Nrng
BSStep = BSStep + 1
Next Brng
Application.ScreenUpdating = True
End Sub
I am going to post another question that I am looking for added on to this.
This would be in regards to if the value is not found, putting "NOTHING IN HISTORY FILE" in red in the cell.
Thanks again guys, would not have been able to find a solution without you pointing me in the right direction.
Here a few hints
You can store your headers in Array(), simplifying the code a lot:
Function rangeToArray(rng As Range) As Variant
rangeToArray = Application.Transpose(Application.Transpose(rng))
End Function
Sub CopyBlastSheetData()
headers = rangeToArray(ThisWorkbook.Worksheets("Blast List").Range("E1:Q1"))
'Rest of the code [..]
End Sub
Instead of repeating the same code define and use a Sub for copying and a Sub for pasting:
Sub copyFrom(ws As Worksheet, rng As Range, search As String)
ws.Select
rng.Select
Cells.Find(What:=search, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
End Sub
Sub PasteTo(ws As Worksheet, rng As Range)
ws.Select
rng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
And then use them on your code like this:
Call copyFrom(ws, Range("A1"), headers(1))
Call PasteTo(ws, Range("E3"))
This represent a good starting point.
I hope this helps.