Related
I am trying to copy from Sheet1, specific rows when on that row a specific cell has status "DONE" selected to say, and a second criteria after "DONE" is to check if on the same row, another cell has also a specific value. After that, copy the rows found each on specific sheet, checking destination if duplicates are found.
I have managed until now to copy from Sheet1 to the other based on the 2 criteria (old school with IF, I tried with autofilter but I didn't manage to do it) but I am having a hard time preventing duplicates to be copied to the other sheets.
I tried everything, value checking based on first sheet with Range, writing a macro for each sheet so it prevents duplicates, nothing worked and i am stuck on this.
Another problem with below code is that after hitting Update button multiple times, it doesn't duplicate all found rows, but only the first one found, and also inserts some empty rows in between and I don't understand the reason for that.
Here is the code:
Private Sub CommandButton1_Click()
Dim LastRow As Long
Dim i As Long, j As Long, k As Long, j1 As Long, k1 As Long, j_last As Long,
k_last As Long
Dim a As Long, b As Long
Dim ActiveCell As String
With Worksheets("PDI details")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Worksheets("Demo ATMC")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 2
End With
With Worksheets("Demo ATMC Courtesy")
k = .Cells(.Rows.Count, "A").End(xlUp).Row + 2
End With
With Worksheets("Demo SHJ")
j1 = .Cells(.Rows.Count, "A").End(xlUp).Row
k1 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Worksheets("Demo AD")
a = .Cells(.Rows.Count, "A").End(xlUp).Row
b = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
MsgBox (j)
For i = 5 To LastRow
With Worksheets("PDI details")
If .Cells(i, 20).Value <> "" Then
If .Cells(i, 20).Value = "DONE" Then
If .Cells(i, 11).Value = "ATMC DEMO" Then
If Not .Cells(i, 7) = Worksheets("Demo ATMC").Range("D4") Then
Worksheets("Demo ATMC").Range("A" & j) = Worksheets("PDI details").Range("A" & i).Value
Worksheets("Demo ATMC").Range("B" & j) = Worksheets("PDI details").Range("E" & i).Value
Worksheets("Demo ATMC").Range("C" & j) = Worksheets("PDI details").Range("F" & i).Value
Worksheets("Demo ATMC").Range("D" & j) = Worksheets("PDI details").Range("G" & i).Value
Worksheets("Demo ATMC").Range("F" & j) = Worksheets("PDI details").Range("H" & i).Value
Worksheets("Demo ATMC").Range("G" & j) = Worksheets("PDI details").Range("I" & i).Value
End If
End If
If .Cells(i, 11).Value = "ATMC COURTESY" Then
If Not .Cells(i, 7) = Worksheets("Demo ATMC Courtesy").Range("D4")
Then
Worksheets("Demo ATMC Courtesy").Range("A" & k) = Worksheets("PDI details").Range("A" & i).Value
Worksheets("Demo ATMC Courtesy").Range("B" & k) = Worksheets("PDI details").Range("E" & i).Value
Worksheets("Demo ATMC Courtesy").Range("C" & k) = Worksheets("PDI details").Range("F" & i).Value
Worksheets("Demo ATMC Courtesy").Range("D" & k) = Worksheets("PDI details").Range("G" & i).Value
Worksheets("Demo ATMC Courtesy").Range("F" & k) = Worksheets("PDI details").Range("H" & i).Value
Worksheets("Demo ATMC Courtesy").Range("G" & k) = Worksheets("PDI details").Range("I" & i).Value
k = k + 1
End If
End If
End If
End If
End With
Next i
End Sub
I couldn't test the code suggested below but I believe that it does what you wish it to do.
Option Explicit
Private Sub CommandButton1_Click()
' 23 Dec 2017
Dim WsPdi As Worksheet
Dim WsAtmc As Worksheet, WsCourtesy As Worksheet
Dim R As Long, Rl As Long ' row / lastrow "PDI details"
Set WsPdi = Worksheets("PDI Detail")
Set WsAtmc = Worksheets("Demo ATMC")
Set WsCourtesy = Worksheets("Demo ATMC Courtesy")
Application.ScreenUpdating = False
With WsPdi
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
For R = 5 To Rl
If .Cells(R, 20).Value = "DONE" Then
Select Case .Cells(R, 11).Value
Case "ATMC DEMO"
TransferData WsPdi, WsAtmc, R
Case "ATMC COURTESY"
TransferData WsPdi, WsCourtesy, R
End Select
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Private Sub TransferData(WsSource As Worksheet, _
WsDest As Worksheet, _
R As Long)
' 23 Dec 2017
Dim Csource() As String
Dim Rn As Long ' next empty row in WsDest
Dim C As Long
Csource = Split(",A,E,F,G,,H,R", ",")
With WsDest
If WsSource.Cells(R, 7).Value <> .Cells(4, "D").Value Then
Rn = .Cells(.LastRow, "A").End(xlUp).Row + 1
For C = 1 To 7 ' columns A to G
If C <> 5 Then
.Cells(Rn, C).Value = WsSource.Cells(R, Csource(C)).Value
End If
Next C
End If
End With
End Sub
I have three columns, one of them having all the staff list IDs, the second is having Front-Line staff IDs, The third is having the Back-office staff IDs, sometimes we change the task to some of them, to work in the different field, So His Staff ID has to disappear from Front-Line col and appear in Back-Office col instead. and Vice-Versa, and this will be done by selecting some of Column A staff, then it will loop through Col B and remove selection value(If found), then add these selected cells to Col B.
The same when we normalize, we select some staff from Col A, It should remove the staff IDs from Col B and add it to col C
All Staff | Front-line | Back-Office
15348 | 15348 | 15344
15347 | 15347 | 15345
15345 |
15344 |
What I've achieved so far.
Excuse me if my codes looks a little bit complex, that's the only way I know.
Dedicate Button (Dedicating 1st Col staffs to work as Back-office)
Dim found As Boolean
Dim i, j, mycount, dedlist As Integer
Dim firstempty As Long
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("L" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
found = False
Selection.Copy
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
Cells(firstempty, 8).Select
Cells(firstempty, 8).PasteSpecial Paste:=xlPasteValues
End With
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("L" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
For i = 2 To mycount
For j = 2 To dedlist
With Sheets("StaffList")
If .Range("H" & i).Value = .Range("L" & j).Value Then
found = True
End If
End With
Next j
If found = False Then
dedlist = dedlist + 1
With Sheets("StaffList")
.Range("L" & dedlist).Value = .Range("H" & i).Value
End With
End If
found = False
Next i
' ActiveSheet.Range("$H$1:$H$500").RemoveDuplicates Columns:=1, Header:=xlYes
Range("A1").Select
Normalize Button (Normalizing 2nd Col staffs to get back working as Front-Line)
Dim CompareRange As Variant, x As Variant, y As Variant
Dim rng As Range
Dim found As Boolean
Dim i, j, mycount, dedlist As Integer
Dim firstempty As Long
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("H" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
found = False
Selection.Copy
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
Cells(firstempty, 13).Select
Cells(firstempty, 13).PasteSpecial Paste:=xlPasteValues
End With
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("H" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
For i = 2 To mycount
For j = 2 To dedlist
With Sheets("StaffList")
If .Range("M" & i).Value = .Range("L" & j).Value Then
.Range("H" & j).Value = ""
End If
End With
Next j
Next i
Range("A1").Select
This is the VBA implementation of the suggestion in comment:
Option Explicit
Public Sub UpdateStaffTasks()
Const FRNT = "Front-line", BACK = "Back-Office"
Dim selRow As Variant, lrSelRow As Long, ws As Worksheet, i As Long, j As Long
Dim usdRng As Variant, lrUsdRng As Long, red As Long, blu As Long
If Selection.Cells.Count = 1 And Selection.Row = 1 Then Exit Sub
Set ws = Selection.Parent
selRow = GetSelRows(Selection): lrSelRow = UBound(selRow): red = RGB(256, 222, 222)
usdRng = ws.UsedRange: lrUsdRng = UBound(usdRng): blu = RGB(222, 222, 256)
For i = 0 To lrSelRow
For j = i + 2 To lrUsdRng
If j = Val(selRow(i)) Then
If Len(usdRng(j, 1)) > 0 And Len(usdRng(j, 2)) > 0 Then
usdRng(j, 2) = IIf(usdRng(j, 2) = FRNT, BACK, FRNT)
With ws.Cells(j, 1).Resize(, 2).Interior
.Color = IIf(usdRng(j, 2) = FRNT, red, blu)
End With
Exit For
End If
End If
Next
Next
Selection.Parent.UsedRange = usdRng
End Sub
Public Function GetSelRows(ByRef selectedRange As Range) As Variant
Dim s As Variant, a As Range, r As Range, result As Variant
If selectedRange.Cells.Count > 1 Then
For Each a In selectedRange.Areas
For Each r In a.Rows
If r.Row > 1 And InStr(s, r.Row) = 0 Then s = s & r.Row & " "
Next
Next
GetSelRows = Split(RTrim$(s)): Exit Function
Else
GetSelRows = Array(selectedRange.Row): Exit Function
End If
End Function
Before and After:
i am having problem with the task i am doing right now. Supposedly,i have a for loop to calculate the MIN and SUM of the used range (tables). Since i have 10 worksheet in the workbook, i added another for loop to loop on each worksheet in the workbook. However, the codes run without error but the output is not as expected. It will calculate even at the unused range. Is there any error on my code?
Sub calc()
Dim ws As Worksheet
Dim y As Workbook
Dim rng As Range
Dim i As Integer, r As Long, j As Long
Set y = ThisWorkbook
For Each ws In y.Worksheets
For Each rng In ws.UsedRange.SpecialCells(xlCellTypeConstants, 3).Areas
If rng.Rows.Count > 1 And rng.Columns.Count = 14 Then
j = 2
r = rng.Cells(rng.Rows.Count, 1).Row + 1
Cells(r, rng.Columns(1).Column).Value = "SUMMARY"
For i = rng.Columns(2).Column To rng.Columns(2).Column + 12
If i = rng.Columns(12).Column Then
Cells(r, i).Formula = "=MIN(" & rng.Columns(j).Address & ")"
j = j + 1
Else
Cells(r, i).Formula = "=SUM(" & rng.Columns(j).Address & ")"
j = j + 1
End If
Next i
End If
Next rng
Next
End Sub
You should always qualify which sheet you are referring to when you use Cells, Range, etc.
For instance, the line
Cells(r, rng.Columns(1).Column).Value = "SUMMARY"
is referring to the active sheet, but you probably want to refer to the sheet that ws is referring to, i.e.
ws.Cells(r, rng.Columns(1).Column).Value = "SUMMARY"
Your code should probably look like:
Sub calc()
Dim ws As Worksheet
Dim y As Workbook
Dim rng As Range
Dim i As Integer, r As Long, j As Long
Set y = ThisWorkbook
For Each ws In y.Worksheets
For Each rng In ws.UsedRange.SpecialCells(xlCellTypeConstants, 3).Areas
If rng.Rows.Count > 1 And rng.Columns.Count = 14 Then
j = 2
r = rng.Cells(rng.Rows.Count, 1).Row + 1
ws.Cells(r, rng.Columns(1).Column).Value = "SUMMARY"
For i = rng.Columns(2).Column To rng.Columns(2).Column + 12
If i = rng.Columns(12).Column Then
ws.Cells(r, i).Formula = "=MIN(" & rng.Columns(j).Address & ")"
j = j + 1
Else
ws.Cells(r, i).Formula = "=SUM(" & rng.Columns(j).Address & ")"
j = j + 1
End If
Next i
End If
Next rng
Next
End Sub
I've written below code. Its a loop inside loop. First loop runs to search 1st range's value (sheet1) in all second loop's all ranges (sheet2). I want second loop to stop if condition is met and proceed with next value.
I'm using "Exit For" to stop 2nd loop if condition is met. but the Problem is....
When First loop = 2, second loop is also 2 and condition is met, second loop stops. First loop becomes = 3 but second loop still remains = 2 which is causing the mismatch and failure to all. Please help.
For I = 2 To REND
For P = 2 To ENDROW
If Range("D" & I) = D.Range("c" & P) Then
If Range("H" & I) = D.Range("F" & P) Then
Range("A" & I) = "MATCHED"
Exit For
Else
Range("A" & I) = "DIFFERENCE OF " & Range("G" & I) - D.Range("F" & P)
End If
Else
Range("A" & I) = "AP NOT FOUND"
End If
Next P
Next I
Where declarations are:
Dim D As Worksheet, F As Worksheet, R As WorksheetDim X As String
Dim I As Integer, ENDROW As Integer, FEND As Integer
Dim P As Integer, REND As Integer, L As Integer
Set D = ActiveWorkbook.Sheets("DWAC")
Set F = ActiveWorkbook.Sheets("FPS")
Set R = ActiveWorkbook.Sheets("RAW")
ENDROW = D.Range("C2").End(xlDown).Row
FEND = F.Range("C2").End(xlDown).Row
REND = R.Range("C2").End(xlDown).Row
From your question, I assume there will be only one result in Sheets("DWAC") column C. With that in mind, we can use find instead of looping until you get a match.
If we cleaned up your Dim statements(there is one sheet not being used in the code & Row variables should be long.
Dim D As Worksheet, R As Worksheet
Dim ENDROW As Long, REND As Long
Dim rng1 As Range, rng2 As Range
Dim c As Range, FndC As Range
Now of course set the worksheets
Set D = Sheets("DWAC")
Set R = Sheets("RAW")
And then find the last rows and set the ranges.
This will find the last row in column c Sheets("DWAC"), the set range is where we want to find the original value from Sheets("RAW")
With D
ENDROW = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng2 = .Range("C2:C" & ENDROW) 'find value in column C sheet D
End With
Then set the loop range from sheets R,this is the range we will be looping through.
With R
REND = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng1 = .Range("D2:D" & REND) 'Loop through column D in sheet R
End With
Now we can start the loop.
c will loop through rng1 and find itself in rng2, FndC will be the range if the c is found.
For Each c In rng1.Cells
Set FndC = rng2.Find(what:=c, lookat:=xlWhole)
If c in found then do something.
If Not FndC Is Nothing Then
If c.Offset(, 4) = FndC.Offset(, 3) Then
c.Offset(, -3) = "Match"
Else
c.Offset(, -3) = "DIFFERENCE OF " & c.Offset(, 3) - FndC.Offset(, 3)
End If
Else: c.Offset(, -3) = "Not Found"
End If
Next c
If I have the Offsets in the wrong order, you can edit to your requirements.
This is what the offsets represent.
c.Offset(, 4)'=Column H Sheet "R"
FndC.Offset(, 3)'=Column F Sheet "D"
c.Offset(, -3)'=Column A Sheet "R"
c.Offset(, 3)'=Column G Sheet "R"
Here's is the complete code.
Sub FindAndStuff()
Dim D As Worksheet, R As Worksheet
Dim ENDROW As Long, REND As Long
Dim rng1 As Range, rng2 As Range
Dim c As Range, FndC As Range
Set D = Sheets("DWAC")
Set R = Sheets("RAW")
With D
ENDROW = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng2 = .Range("C2:C" & ENDROW) 'find value in column C sheet D
End With
With R
REND = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng1 = .Range("D2:D" & REND) 'Loop through column D in sheet R
End With
For Each c In rng1.Cells
Set FndC = rng2.Find(what:=c, lookat:=xlWhole)
If Not FndC Is Nothing Then
If c.Offset(, 4) = FndC.Offset(, 3) Then
c.Offset(, -3) = "Match"
Else
c.Offset(, -3) = "DIFFERENCE OF " & c.Offset(, 3) - FndC.Offset(, 3)
End If
Else: c.Offset(, -3) = "Not Found"
End If
Next c
End Sub
The best way I know is to use booleans:
Dim chck As Boolean
Dim chck2 As Boolean
For I = 2 To REND
chck = False
chck2 = False
For P = 2 To ENDROW
If Range("D" & I) = D.Range("c" & P) Then
chck = True
If Range("H" & I) = D.Range("F" & P) Then
chck2 = True
Exit For
End If
end if
Next P
If chck And chck2 Then
Range("A" & I) = "MATCHED"
ElseIf chck Then
Range("A" & I) = "DIFFERENCE OF " & Range("G" & I) - D.Range("F" & P)
Else
Range("A" & I) = "AP NOT FOUND"
End If
Next I
Why does the following VBA script not show any message boxes when row 4, 5 and 6 are all empty...
Sub Test()
LastRow = 40
For i = LastRow To 3 Step -1
Set myRange = Range("B" & i & ":T" & i)
If WorksheetFunction.CountA(myRange) = 0 Then
MsgBox "Empty " & Cells(i, 1).Row
Else
x = x
End If
Next
End Sub
Just test both column ranges:
Sub Test()
LastRow = 40
For i = LastRow To 3 Step -1
count = WorksheetFunction.CountA(Range("B"&i & ":D"&i))
count = count + WorksheetFunction.CountA(Range("F"&i & ":T"&i))
If count = 0 Then
MsgBox "Empty " & i
End If
Next
End Sub
edit: or build a range object which contains the two column ranges, intersect that with the last row, and move this range object in the loop. This way, you don't build the range object anew in each iteration:
Sub Test()
Dim rng As Range, colrng As Range
Dim LastRow As Long
Dim i As Long
LastRow = 40
Set colrng = Application.Union(Range("B:D"), Range("F:T"))
Set rng = Application.Intersect(colrng, Rows(LastRow))
For i = LastRow To 3 Step -1
If WorksheetFunction.CountA(rng) = 0 Then
MsgBox "Empty row: " & i
End If
Set rng = rng.Offset(-1, 0)
Next
End Sub
As good practice, always declare your variables, and use long integers for row or column indices.
Sub Test()
LastRow = 40
For i = LastRow To 3 Step -1
Set myRange = Range("B" & i & ":T" & i)
If WorksheetFunction.CountIf(myRange,"<>") = 0 Then 'count where it's not a null or empty string
MsgBox "Empty " & Cells(i, 1).Row
Else
x = x
End If
Next
End Sub
The only way I can seem to do it is a slow way:
LastRow = Range("B:Z").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
For i = LastRow To 3 Step -1
BlankRow = False
For j = 2 To LastColumn
If Cells(i, j).Value <> "" Then
Blank = False
Exit For
End If
BlankRow = True
Next j
If BlankRow = True Then
x = x
End If
Next i