I am totally new in macro's so I would like to know where did I make mistakes in my code.
I just want a simple IF - AND based on 2 different columns and the result should be in the third column
My code is:
Sub FTL_Customer3()
Lastrow = Sheets("Raw data").Range("D" & Rows.Count).End(xlUp).Row
For i = 1 To Lastrow
If Sheets("Raw data").Cells(i, 5) = "Postponed to next month" And Sheets("Raw
data").Cells(i, 13) = "ATP Ship date after EOM" Then
Cells(i, 7).Value = "OK"
End If
Next I
End Sub
Ensure the cells you will be testing do not contain an error:
Sub FTL_Customer3()
With Worksheets("Raw data")
Dim LastRow As Long
LastRow = .Range("D" & .Rows.Count).End(xlUp).Row
Dim i As Long
For i = 1 To LastRow
If Not IsError(.Cells(i, 5)) And Not IsError(.Cells(i, 13)) Then
If .Cells(i, 5) = "Postponed to next month" And _
.Cells(i, 13) = "ATP Ship date after EOM" Then
.Cells(i, 7).Value = "OK"
End If
End If
Next i
End With
End Sub
Related
I have a sheet with Columns A to P.
In columns B i have customer names. Want to find rows with substring “ABC -“ and copy the content of the cell in column B to Column G on the same row.
My code fails on this:
For I= 1 to finalrow
If Left(Cells(I,2).Value,5) = “ABC -“ Then
Rownumber= ActiveCell.Row
Range("B" & Rownumber).Select
Range("B" & Rownumber).Copy
Range("G" & rownumber).Select
ActiveSheet.Paste
Range("G" & rownumber).Select
End if
Next I
This one works as expected, writing the values from column "B" to column "G":
Sub TestMe()
Dim i As Long
For i = 1 To 10
With ThisWorkbook.Worksheets("Sheet1")
Dim myCell As Range
Set myCell = .Cells(i, "B")
If Trim(Left(myCell.Value, 5)) = "ABC -" Then
.Cells(i, "G").Value = myCell.Value
End If
End With
Next i
End Sub
Try to avoid .Select and .Activate - https://stackoverflow.com/a/35864330/5448626
Use Trim()
Using . and referring the worksheet is always a good practice
.Cells(i, "B") improves readability
“ probably should be "
For I = 1 To finalrow
With Cells(I, 2)
If .Text Like "ABC -*" Then .Offset(0, 5) = .Value
End With
Next I
For I = 1 to finalrow
If Left(Cells(I,2).Value,5) = "ABC -" Then
Cells(I,7).Value = Cells(I,2).Value
End if
Next I
i would help me about my code it compares from sheet1 two columns a,b and the duplicated transfer to sheet2 the column c
Sub COPY1()
Dim i
Dim LastRow As Long
LastRow = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Sheets("sheet1").Cells(i, "A").Value = Sheets("sheet1").Cells(i, "B").Value Then
Count = Application.WorksheetFunction.CountIf(Range("B1:B" & i), Sheets("sheet1").Cells(i, "A"))
If Count > 1 Then
Sheets("sheet1").Cells(i, "A").COPY Destination:=Sheets("sheet2").Range("B" &
Rows.Count).End(xlUp).Offset(1)
End If
End If
Next i
End Sub
Give this a try:
Sub COPY1()
Dim i As Long
Dim LastRow As Long
With Sheets("sheet1")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
v = .Cells(i, "A").Value
For j = 2 To LastRow
If v = .Cells(j, "B").Value Then
.Cells(i, "A").Copy Destination:=Sheets("sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1)
End If
Next j
Next i
End With
End Sub
I currently have a macro that inserts 3 rows when the value in Column E changes (Course Department). In the 3 rows I am trying to merge the middle row and add the department into this row. I can't work out how to get it to merge, any help would be appreciated.
With Range("e" & myHeader + 2, Range("e" & Rows.Count).End(xlUp)).Offset(, 1)
.Formula = _
"=if(and(r[-1]c[-1]<>"""",rc[-1]<>"""",r[-1]c[-1]<>rc[-1])," & _
"if(r[-1]c=1,""a"",1),"""")"
.Value = .Value
On Error Resume Next
For i = 1 To 3
.SpecialCells(2, 1).EntireRow.Insert
.SpecialCells(2, 2).EntireRow.Insert
Next
This is how it is currently:
This is what I would like to have:
When inserting or deleting rows, work from the bottom up. Some simple offsets and resizing should be sufficient to insert the three rows, merge the cells and transfer the values.
Option Explicit
Sub insertDept3()
Dim i As Long
With Worksheets("sheet10")
For i = .Cells(.Rows.Count, "E").End(xlUp).Row - 1 To 1 Step -1
If .Cells(i, "E").Value <> .Cells(i + 1, "E").Value Or i = 1 Then
.Cells(i + 1, "A").Resize(3, 5).Insert shift:=xlDown
.Cells(i + 2, "A").Resize(1, 5).Merge
.Cells(i + 2, "A") = .Cells(i + 4, "E").Value
End If
Next i
End With
End Sub
I will leave the cell alignment and font formatting to you.
The below code loop column E, import three lines when the value change, merger Column A to column E , import and format value in the middle line.
Try:
Option Explicit
Sub test()
Dim i As Long, Lastrow As Long
Dim Department As String, NextDepartment As String
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "E").End(xlUp).Row
For i = Lastrow To 2 Step -1
Department = .Range("E" & i).Value
NextDepartment = .Range("E" & i).Offset(-1, 0).Value
If Department <> NextDepartment Then
.Rows(i).EntireRow.Resize(3).Insert
.Range("A" & i + 1 & ":E" & i + 1).Merge
With .Range("A" & i + 1)
.Value = Department
.Font.Bold = True
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
End If
Next i
End With
Output:
I am creating a summary macro and I need to add up all the values of column C and D into the merged cell in E. In the image attached the sums are already placed to show the result I want. I already have code to merge the cells in column E based on the names in A. IE Sum up all overdue and critical for bob and place in merged column, then nick. Here is what I have I just need help getting the sum:
Sub MergeSameCell()
Dim Rng As Range, xCell As Range
Dim xRows As Integer
Set WorkRng = ThisWorkbook.Worksheets("Summary").Range("A:A")
lastRow = ActiveSheet.Columns("A").Cells.Find("*", SearchOrder:=xlByRows,
LookIn:=xlValues, SearchDirection:=xlPrevious).Row
xRows = lastRow
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
WorkRng.Parent.Range(Rng.Cells(i, 5), Rng.Cells(j - 1, 5)).Merge
i = j - 1
Next
Next
End Sub
The below uses your enclosed data specifically and assumes the data has already been sorted by column A and the cells in column E are already merged.
Public Sub GroupSum()
Dim i0 As Long, i1 As Long, strName As String
With ActiveSheet
For i0 = 2 To .UsedRange.Rows.Count
If Not .Cells(i0, 1).Value = strName Then
strName = .Cells(i0, 1)
i1 = i0
End If
.Cells(i1, 5).Value = .Cells(i0, 3).Value + .Cells(i0, 4).Value + .Cells(i1, 5).Value
Next i0
End With
End Sub
I will leave the alignment formatting of the merged cells to you.
Option Explicit
Sub MergeSameCell()
Dim clientRng As Range
Dim lastRow As Long, lastClientRow As Long
With ThisWorkbook.Worksheets("Summary")
.Columns(5).UnMerge
Set clientRng = .Range("A2")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Do
lastClientRow = .Columns(1).Find(what:=clientRng.Value, after:=clientRng, _
lookat:=xlWhole, SearchDirection:=xlPrevious).Row
With clientRng.Offset(0, 4)
.Resize(lastClientRow - clientRng.Row + 1, 1).Merge
.Formula = "=sumifs(c:c, a:a, " & Chr(34) & clientRng.Value2 & Chr(34) & ")+" & _
"sumifs(d:d, a:a, " & Chr(34) & clientRng.Value2 & Chr(34) & ")"
'optionally revert the formulas to their returned value
'value = .value2
End With
Set clientRng = clientRng.Offset(lastClientRow - clientRng.Row + 1, 0)
Loop While clientRng.Row <= lastRow
End With
End Sub
This removes a couple of loops:
Sub MergeSameCell()
With ThisWorkbook.Worksheets("Summary")
Dim i as Long
For i = 2 To .Rows.Count
If .Cells(i, 1) = "" Then Exit Sub
Dim x As Long
x = .Evaluate("MATCH(TRUE," & .Cells(i, 1).Address & "<>" & .Range(.Cells(i, 1), .Cells(.Rows.Count, 1)).Address & ",0) - 2 + " & i)
.Cells(i, 5).Value = Application.Sum(.Range(.Cells(i, 3), .Cells(x, 4)))
.Range(.Cells(i, 5), .Cells(x, 5)).Merge
i = x
Next i
End With
End Sub
Struggling a bit with this code, I haven't ever had to reference one column and copy and paste to another tab in VBA so here goes..
I have an excel document with a table on it similar to below:
I need my code to look in column A find the first name, in this case, Nicola. I then want it to look at column B and check to see if she has the word "Internet" appear in any of the records stored against her, as she does the code will ignore her and move down to the next name on the list, in this case, Graham. It will then look to column B and check if he has the word "Internet". As he doesn't, the code needs to copy the Information from column A & B in relation to this persons name and paste the information into another sheet in the workbook.
Sub Test3()
Dim x As String
Dim found As Boolean
Range("B2").Select
x = "Internet"
found = False
Do Until IsEmpty(ActiveCell)
If ActiveCell.Value = x Then
found = True
Exit Do
End If
ActiveCell.Offset(1, 0).Select
Loop
If found = False Then
Sheets("Groupings").Activate
Sheets("Groupings").Range("A:B").Select
Selection.Copy
Sheets("Sheet1").Select
Sheets("Sheet1").Range("A:B").PasteSpecial
End If
End Sub
Any help would be greatly appreciated.
Thanks
Paula
Private Sub Test3()
Application.ScreenUpdating = False
Set sh1 = Sheets("Groupings") 'data sheet
Set sh2 = Sheets("Sheet1") 'paste sheet
myVar = sh1.Range("D1")
Lastrow = sh1.Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow '2 being the first row to test
If Len(sh1.Range("A" & i)) > 0 Then
Set myFind = Nothing
If WorksheetFunction.CountA(sh1.Range("A" & i, "A" & Lastrow)) > 1 Then
If Len(sh1.Range("A" & i + 1)) = 0 Then
nextrow = sh1.Range("A" & i).End(xlDown).Row - 1
Else
nextrow = nextrow + 1
End If
Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar, LookIn:=xlFormulas, LookAt:=xlWhole)
Else
nextrow = Lastrow
Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar, LookIn:=xlFormulas, LookAt:=xlWhole)
End If
If myFind Is Nothing Then
sh1.Range("A" & i, "B" & nextrow).Copy
sh2.Range("A" & sh2.Range("B" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End If
Next
End Sub
I don't clearly see the structure of your data, but assuming the original data is in Worksheet Data, I think the following is going to do what you want (edited to search for two conditions).
Private Sub Test3()
Dim lLastRow as Long
Dim a as Integer
Dim i as Integer
Dim sText1 As String
Dim sText2 As String
sText1 = Worksheets("Data").Cells(1, 5).Value 'search text #1, typed in E1
sText2 = Worksheets("Data").Cells(2, 5).Value 'search text #2, typed in E2
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
a = 1
For i = 2 To lLastRow
If (Worksheets("Data").Cells(i, 1).Value <> "") Then
If (Worksheets("Data").Cells(i, 2).Value <> sText1 And Worksheets("Data").Cells(i + 1, 2).Value <> sText1 And Worksheets("Data").Cells(i, 2).Value <> sText2 And Worksheets("Data").Cells(i + 1, 2).Value <> sText2) Then
Worksheets("Groupings").Cells(a, 1).Value = Worksheets("Data").Cells(i, 1).Value
Worksheets("Groupings").Cells(a, 2).Value = Worksheets("Data").Cells(i, 2).Value
Worksheets("Groupings").Cells(a, 3).Value = Worksheets("Data").Cells(i + 1, 2).Value
a = a + 1
End If
End If
Next
End Sub