I have a sheet1 data in below format
I need VBA Code to vlookup in sheet2 on Group Id and Product ID in sheet1 and insert new row highlighted in yellow called BT order and populate 400 and 600 values from DMD column against Wk8 and Wk9 column which is vlookup value of week Num from second sheet.
Dim i As Long
For i = 2 To Range("E" & Rows.Count).End(xlUp).Row
If Trim(Range("E" & i).Value) = RTrim("CMT") Then
Rows(i + 1).Insert shift:=xlShiftDown
Range("A" & i + 1 & ":D" & i + 1).Value = Range("A" & i - 1 & ":D" & i - 1).Value
Range("E" & i + 1).Value = "BT/Order"
End If
Next i
Try this:
Sub Tester()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Long, i2 As Long, grp, prod, amt, wk
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
i = 2
Do While i <= ws1.Cells(Rows.Count, "E").End(xlUp).Row
If Trim(ws1.Range("E" & i).Value) = RTrim("CMT") Then
ws1.Rows(i + 1).Insert shift:=xlShiftDown
ws1.Cells(i + 1, "A").Resize(1, 4).Value = ws1.Cells(i, "A").Resize(1, 4).Value
ws1.Cells(i + 1, "E").Value = "BT/Order"
'current group/product id's
grp = ws1.Cells(i, "A").Value
prod = ws1.Cells(i, "C").Value
'loop sheet2 and find matches
For i2 = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
If ws2.Cells(i2, "A").Value = grp Then
If ws2.Cells(i2, "B").Value = prod Then
'got match - check amount and week
amt = ws2.Cells(i2, "D").Value
wk = ws2.Cells(i2, "E").Value
If amt > 0 Then
'insert amount in relevant column
ws1.Cells(i + 1, "F").Offset(0, wk).Value = amt
End If
End If
End If
Next i2
End If
i = i + 1
Loop
End Sub
Related
im trying to make a vba code that will detect when Active balancing is on ( A value in cell ) and then copy the previous tension value, and simillarly do the same at the end of Active balancing to copy the next tension value. (see picture for more explanation).
im planing to show those values in another sheet
thanks to the help of Mr.PeterT i modified his code to do it but i couldn't succeed. thanks for you help and mentoring guys!
image of values i want to extract
Option Explicit
Sub find_balanced_cells_and_tensions()
FindWith "A"
End Sub
Sub FindWith(checkValue As Variant)
Dim destinationSheet As Worksheet
Set destinationSheet = ThisWorkbook.Sheets.Add
destinationSheet.Name = "Equilibrage.actif.info"
Dim destRow As Long
destRow = 1
Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Sheets("Equilibrage.passif")
Dim lastRow As Long
Dim lastColumn As Long
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row
lastColumn = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column
Dim i As Long
Dim j As Long
For j = 1 To lastColumn
For i = 2 To lastRow
If sourceSheet.Cells(i, j).Value = checkValue _
& sourceSheet.Cells(i + 1, j).Value = checkValue Then
sourceSheet.Cells(i - 1, j - 1).Copy _
Destination:=destinationSheet.Range("A" & destRow)
destRow = destRow + 1
ElseIf sourceSheet.Cells(i, j).Value = checkValue _
& sourceSheet.Cells(i + 1, j).Value <> checkValue Then
sourceSheet.Cells(i + 1, j - 1).Copy _
Destination:=destinationSheet.Range("B" & destRow)
destRow = destRow + 1
Exit For 'immediately skip to the next row
End If
Next i
Next j
End Sub
Untested but should be close.
I will test if you can share a sample dataset.
Sub find_balanced_cells_and_tensions()
FindWith "A"
End Sub
Sub FindWith(checkValue As Variant)
Dim sourceSheet As Worksheet
Dim destinationSheet As Worksheet
Dim destRow As Long, lastRow As Long, lastColumn As Long, valCount As Long
Dim i As Long, j As Long, preVal, postval, cellLabel, dt, tm
Set sourceSheet = ThisWorkbook.Sheets("Equilibrage.passif")
Set destinationSheet = ThisWorkbook.Sheets.Add()
destinationSheet.Name = "Equilibrage.actif.info"
destRow = 1
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row
lastColumn = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column
For j = 4 To lastColumn Step 2 'only process relevant columns
i = 3
Do 'from 3 to lastrow-1 to allow for -1 at top and +1 at bottom
If sourceSheet.Cells(i, j).Value = checkValue Then
dt = sourceSheet.Cells(i - 1, 1).Value 'collect start info
tm = sourceSheet.Cells(i - 1, 2).Value
cellLabel = sourceSheet.Cells(1, j).Value
preVal = sourceSheet.Cells(i - 1, j - 1).Value
valCount = 1 'how many values in this run?
Do While sourceSheet.Cells(i, j).Offset(valCount).Value = checkValue
valCount = valCount + 1
Loop
postval = sourceSheet.Cells(i + valCount, j - 1).Value
destinationSheet.Cells(destRow, 1).Resize(1, 5).Value = _
Array(dt, tm, cellLabel, preVal, postval)
destRow = destRow + 1
i = i + valCount
End If
i = i + 1
Loop While i < lastRow
Next j
End Sub
So after countless hit and miss and the help of Tim Williams and Funthomas, i arrived to this code that does the job plus some things.
the worksheet to get the values from is this one :
Value source
And the result of the code is like this :
Results
the final code is like this :
Option Explicit
Sub find_balanced_cells_and_tensions_A()
FindWith "A" ' we can replace A by any value we want to look for here
End Sub
Sub FindWith(checkValue As Variant)
Dim destinationSheet As Worksheet
Set destinationSheet = ThisWorkbook.Sheets.Add
destinationSheet.Name = "Equilibrage.actif.info"
'___ variables to track cells where will put our extacted values _______
Dim destRow As Long
destRow = 1
Dim destRow2 As Long
destRow2 = 1
'______ source sheet where we take our values from ___________
Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Sheets("Equilibrage.passif")
'_____ defining the end of columns and rows to end scaning for values _____________
Dim lastRow As Long
Dim lastColumn As Long
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row
lastColumn = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column
Dim i As Long
Dim j As Long
For j = 1 To lastColumn
For i = 2 To lastRow
'_____this part is to detect the start of balancing and taking the tension value of the previous row______________________
If sourceSheet.Cells(i, j).Value = checkValue _
And sourceSheet.Cells(i - 1, j).Value = 0 Then
sourceSheet.Cells(i - 1, j - 1).Copy _
Destination:=destinationSheet.Range("E" & destRow)
Range("A" & destRow).Value = sourceSheet.Cells(1, j)
Range("B" & destRow).Value = "was actively balanced at"
Range("C" & destRow).Value = sourceSheet.Cells(i, 2)
Range("D" & destRow).Value = "from"
Range("F" & destRow).Value = "to"
destRow = destRow + 1
'______ this condition is for when the balancing starts at the first row of the table so we take the present tension instead of the previous ___________
ElseIf sourceSheet.Cells(i, j).Value = checkValue _
And sourceSheet.Cells(i - 1, j).Value <> checkValue _
And sourceSheet.Cells(i - 1, j).Value <> 0 Then
sourceSheet.Cells(i, j - 1).Copy _
Destination:=destinationSheet.Range("E" & destRow)
Range("A" & destRow).Value = sourceSheet.Cells(1, j)
Range("B" & destRow).Value = "was actively balanced at"
Range("C" & destRow).Value = sourceSheet.Cells(i, 2)
Range("D" & destRow).Value = "from"
Range("F" & destRow).Value = "to"
destRow = destRow + 1
End If
'_____to find the next tension value after the end of balancing _____________
If sourceSheet.Cells(i, j).Value = checkValue _
And sourceSheet.Cells(i + 1, j).Value <> checkValue _
And IsEmpty(sourceSheet.Cells(i + 1, j).Value) = False Then
sourceSheet.Cells(i + 1, j - 1).Copy _
Destination:=destinationSheet.Range("G" & destRow2)
Range("H" & destRow2).Value = "at"
Range("I" & destRow2).Value = sourceSheet.Cells(i + 1, 2)
destRow2 = destRow2 + 1
'_____in case the balancing ends at the last row we take the present tension as the next one doesnt exist _____________
ElseIf sourceSheet.Cells(i, j).Value = checkValue _
And IsEmpty(sourceSheet.Cells(i + 1, j).Value) = True Then
sourceSheet.Cells(i, j - 1).Copy _
Destination:=destinationSheet.Range("G" & destRow2)
Range("H" & destRow2).Value = "at"
Range("I" & destRow2).Value = sourceSheet.Cells(i, 2)
destRow2 = destRow2 + 1
End If
Next i
Next j
'_____ Cells modification and formating _________________
Range("C:C").NumberFormat = "hh:mm:ss"
Range("I:I").NumberFormat = "hh:mm:ss"
Range("E:E").Style = "Normal"
Range("G:G").Style = "Normal"
Range("A:K").Font.Size = 14
Range("E:E").Font.Bold = True
Range("G:G").Font.Bold = True
Worksheets("Equilibrage.actif.info").Columns.AutoFit
End Sub
Following code is suggested by a helpful user, this works well to Calculate "From", "To", "MAX" etc values of a range. But this code gives results in every row of a range. I want to get the results in only first row of each row. Please help with this.
Sub trial()
Dim lastrow As Long
Dim destSht As Worksheet
Dim i As Long, j As Long
Set destSht = Worksheets("Final")
With Worksheets("Source")
lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 2 To lastrow + 1 'loop whole range (column C)
If .Cells(i, "C") <> "" Then 'If column C is not empty then
For j = i To lastrow + 1 'Loop "group" range to find next empty cell. Start from current loop i to last row and add one row to get to next empty cell.
If .Cells(j, "C") = "" Then 'When next empty cell is found (i.e. end of small group range) then apply formulas
.Cells(i, "E").Value = .Cells(i, "B").Value 'From
.Cells(i, "F").Value = .Cells(j - 1, "B").Value 'To
.Cells(i, "G").Formula = "=MAX(C" & i & ":C" & j - 1 & ")" 'MAX
.Cells(i, "H").Formula = "=MIN(C" & i & ":C" & j - 1 & ")" 'MIN
.Cells(i, "I").Formula = "=AVERAGE(C" & i & ":C" & j - 1 & ")" 'AVG
Exit For
End If
Next j
End If
Next I
End With
End Sub
This Code gives following result
Desired Result
Try changing this line:
If .Cells(i, "C") <> "" Then 'If column C is not empty then
To this line:
If .Cells(i, "C") <> "" AND .Cells(i-1, "C") = "" Then 'If column C is not empty AND the column C above is empty then
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'm trying to make multiple selections from Sheet2. The value is from the same column but different rows (thinking if using ActiveCell.Offset(1,0) will be feasible).
My code takes the value from an ActiveCell select and runs a macro compares it to another sheet (Sheet10) with some information to copy and paste in a target sheet (Sheet5).
The following is the code that I have right now.
a = Sheet10.Cells(Rows.Count, 1).End(xlUp).Row
c = Sheet2.Cells(Rows.Count, 5).End(xlUp).Row
For Each cell In Range(ActiveCell, ActiveCell.Offset(1, 0))
For i = 2 To a 'from Row 1 to the last row of "DMP"
Debug.Print ("i = " & i)
If cell.Value = Sheet10.Cells(i, 1).Value Then 'if selected cell matches (i,1) of "Sheet10 (DMP)"
Debug.Print ("ActiveCell =" & ActiveCell.Value)
For k = 1 To 20 'from Column 1 to Column 20
Debug.Print ("k = " & k)
For r = 1 To c 'from Row 1 to the last row of "Sheet 2(LightOn SKU)"
Debug.Print ("r = " & r)
If Sheet10.Cells(i, k).Value = Sheet2.Cells(r, 4).Value Then 'if value of (i,k) of "Sheet10 (DMP)" = (r,4) of "Sheet2 (LightOn SKU)"
Sheet2.Range("A" & r & ":G" & r).Copy
Sheet5.Activate
b = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
Sheet5.Cells(b + 1, 1).Select
ActiveSheet.Paste
Range("A" & r & ":L" & r).Borders.Color = vbBlack
End If
Next
Next
End If
Next
Next
Right now, it's running on an endless loop.
Still Unclear
Sub ACCopy2()
Dim a As Long
Dim c As Long
Dim r As Long
Dim i As Long
Dim k As Integer
Dim b As Long
a = Sheet10.Cells(Rows.Count, 1).End(xlUp).Row
c = Sheet2.Cells(Rows.Count, 5).End(xlUp).Row
For r = 1 To c ' from Row 1 to the last row of "Sheet 2(LightOn SKU)"
Debug.Print ("r = " & r)
For i = 2 To a ' from Row 1 to the last row of "DMP"
Debug.Print ("i = " & i)
' if selected cell matches (i,1) of "Sheet10 (DMP)"
If Sheet2.Cells(r, 1).Value = Sheet10.Cells(i, 1).Value Then
Debug.Print ("Sheet2 =" & Sheet2.Cells(r, 1).Value)
For k = 1 To 20 ' from Column 1 to Column 20
Debug.Print ("k = " & k)
' if value of (i,k) of "Sheet10 (DMP)" = (r,4) of
' "Sheet2 (LightOn SKU)"
If Sheet10.Cells(i, k).Value = Sheet2.Cells(r, 4).Value Then
With Sheet5
b = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
Sheet2.Range("A" & r & ":G" & r).Copy .Cells(b + 1, 1)
.Range("A" & r & ":L" & r).Borders.Color = vbBlack
End With
End If
Next
End If
Next
Next
End Sub
i have to sort data from sheet1 to sheet2 with reference to non-empty cell in column A. and
i have written code for it as below:
Sub polo()
Dim lastrow As Long
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = Sheets("Sheet1").Cells(i - 1, 2).Value
j = j + 1
End If
Next i
End Sub
But the problem is, i am getting result as in column D of sheet2.
I want result as shown in column E.
Please help.
Try this version:
Sub polo()
Dim lastrow As Long
Dim sTemp as String
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = stemp
j = j + 1
Else
stemp = Sheets("Sheet1").Cells(i, 2).Value
End If
Next i
End Sub