I have excel file with filled two columns. First, includes numbers, second letter. I want to fill third column by letter with condition:
IF the same number has "A" in any cells in second colum THEN fill with the letter A every cells for this number in third column
ELSEIF "B" THEN B in third column...
Priority A>B>C>D
use this
Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim Cl As Range, i&
i = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For Each Cl In ActiveSheet.Range("A1:A" & i)
If Not Dic.exists(Cl.Value & Cl.Offset(, 1).Value) Then
Dic.Add (Cl.Value & Cl.Offset(, 1).Value), Cl.Row
End If
Next
For Each Cl In ActiveSheet.Range("A1:A" & i)
If Dic.exists(Cl.Value & "A") Then
Cl.Offset(, 2).Value = "A"
ElseIf Dic.exists(Cl.Value & "B") Then
Cl.Offset(, 2).Value = "B"
ElseIf Dic.exists(Cl.Value & "C") Then
Cl.Offset(, 2).Value = "C"
ElseIf Dic.exists(Cl.Value & "D") Then
Cl.Offset(, 2).Value = "D"
End If
Next
End Sub
output result is
updated against new requirements
use this
Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim Cl As Range, i&, key As Variant
i = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For Each Cl In ActiveSheet.Range("A1:A" & i)
If Not Dic.exists(Cl.Value & Cl.Offset(, 1).Value) Then
Dic.Add (Cl.Value & Cl.Offset(, 1).Value), Cl.Row
End If
Next
For Each Cl In ActiveSheet.Range("A1:A" & i)
For Each key In Dic
If UCase(key) Like Cl.Value & "*A*" Then
Cl.Offset(, 2).Value = Mid(key, 2, 100)
Exit For
End If
Next
If Cl.Offset(, 2).Value = Empty Then
For Each key In Dic
If UCase(key) Like Cl.Value & "*B*" Then
Cl.Offset(, 2).Value = Mid(key, 2, 100)
Exit For
End If
Next
End If
If Cl.Offset(, 2).Value = Empty Then
For Each key In Dic
If UCase(key) Like Cl.Value & "*C*" Then
Cl.Offset(, 2).Value = Mid(key, 2, 100)
Exit For
End If
Next
End If
If Cl.Offset(, 2).Value = Empty Then
For Each key In Dic
If UCase(key) Like Cl.Value & "*D*" Then
Cl.Offset(, 2).Value = Mid(key, 2, 100)
Exit For
End If
Next
End If
Next
End Sub
output result
If you can use formula instead of VBA following formula would do the job:
=IF(COUNTIFS(A:A,A2,B:B,"A")>0,"A",IF(COUNTIFS(A:A,A2,B:B,"B")>0,"B",IF(COUNTIFS(A:A,A2,B:B,"C")>0,"C","D")))
in this formula COUNTIF function is combining 2 criterias and counting if these criterias meet or not, then IF functions are inputting related letter to the cell.
Related
I have an array of data, a screenshot of it will be linked at the bottom of this text. Row and column references are to the screenshot.
I am trying to write a macro that will output all the dates that occur within the dynamic range (Column H). And then in column I I want the column header # row i.e I4.
But if there is more than 1 count at the date, I would like the second school to output into column J. As it would for the date 26/03/18, looking like this:
h5 = 26/03/18 , i5(Event1) = Task 2 # 1, j5(Event2) = task 2 # 4
I have tried many ways today and would like some assistance.
Screenshot: https://ibb.co/cmiGSc
My Code thus far(For the more complex sheet):
Sub Events()
'How many schools there are
Dim sh As Worksheet
' This needs to change for each sheets
Set sh = ThisWorkbook.Sheets("Easter 18")
Dim k As Long
k = sh.Range("A3").End(xlDown).Row 'Counts up from bottow - Number of schools attained
Ro = Range("M52").value = k - 2 'Elimiates the two top rows as headers
'Now I need to search the Range of dates
Dim TaskDates As Range
Dim StartCell As Range 'First part of Array
Dim EndCell As Range 'End of Array
Set EndCell = Range("J" & 2 + k) 'maybe 2 or 3
Set StartCell = Range("G3")
Set TaskDates = Range(StartCell, EndCell) 'Dynamic Range
'Within the range of data print out the most left row header (school name) - and task with # in the middle - ascending
' If Column has date (true) create a table with Date (col 1), Event (col 2), Event 2 (Col3) etc etc
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim varray As Variant, element As Variant
varray = TaskDates.value
'Generate unique list and count
For Each element In varray
If dict.exists(element) Then
dict.item(element) = dict.item(element) + 1
Else
dict.Add element, 1
End If
Next
'Paste report somewhere -
'First line ouptuts the dates occured
sh.Range("M55").Resize(dict.Count).value = 'Was working now saying syntax error for this line.
WorksheetFunction.Transpose (dict.keys)
' The count works if cell format is correct
CDates = sh.Range("N55").Resize(dict.Count, 1).value = _
WorksheetFunction.Transpose(dict.items)
End Sub
Please feel free to redesign it if you see fit.
you can go this way
Option Explicit
Sub Tasks()
Dim cell As Range, f As Range
With Worksheets("schools") 'change "schools" to your actual sheet name
For Each cell In .Range("C4:F" & .Cells(.Rows.Count, "B").End(xlUp).Row) 'reference its column C:F from row 4 down to column B last not empty cell
If IsDate(cell.value) Then 'if current cell value is a valid date
Set f = .Range("H3", .Cells(.Rows.Count, "H").End(xlUp)).Find(what:=cell.value, lookat:=xlWhole, LookIn:=xlValues) 'try finding the date in column H
If f Is Nothing Then Set f = .Cells(.Rows.Count, "H").End(xlUp).Offset(1) 'if date not already in column H then get its first empty cell after last not empty one
f.value = cell.value 'write the date (this is sometimes not necessary, but not to "ruin" the code)
.Cells(f.Row, .Columns.Count).End(xlToLeft).Offset(, 1).value = .Cells(3, cell.Column).value & " #" & .Cells(cell.Row, 2).value ' write the record in the first not empty cell in the "date" row
End If
Next
End With
End Sub
Took a shot at this. Just a couple nested loops testing against the dates, making sure that the date found isn't already listed under the date column. As I stated before, you never said what to do if more than 3 dates are found, so I had to add a fourth event column and assume that that's the max. Anything more than 4 dates won't be recorded anywhere, FYI.
Sub MoveDates()
Dim i As Long, j As Long, sht As Worksheet, lastrow As Long, lastrow2 As Long, refrow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row + 1
For i = 4 To lastrow
For j = 3 To 6
If Cells(i, j).Value <> "" And Cells(i, j).Value <> "n/a" Then
If Not Application.WorksheetFunction.CountIf(Range("H4:H" & lastrow), Cells(i, j)) > 0 Then
lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row + 1
Range("H" & lastrow2).Value = Cells(i, j).Value
If Range("I" & lastrow2).Value = "" Then
Range("I" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("J" & lastrow2).Value = "" Then
Range("J" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("K" & lastrow2).Value = "" Then
Range("K" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("L" & lastrow2).Value = "" Then
Range("L" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
End If
Else
lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row
For k = 4 To lastrow2
If Range("H" & k).Value = Cells(i, j).Value Then
refrow = k
Exit For
End If
Next k
If Range("I" & refrow).Value = "" Then
Range("I" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("J" & refrow).Value = "" Then
Range("J" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("K" & refrow).Value = "" Then
Range("K" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("L" & refrow).Value = "" Then
Range("L" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
End If
End If
End If
Next j
Next i
End Sub
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 use the below code to color the cells in column K and Z that match the criteria; but it colors all cells between K and Z. To fix, I use the last line of code to remove the color in columns L thru Y. Is there a way to modify the line of code that starts with "Range" to only color cells K and Z that match the criteria?
Sub ColrCls()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("K" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Cells(i, 11).Value = "Non Sen" And .Cells(i, 26).Value = "N/A" Then
Range(.Cells(i, 11), .Cells(i, 26)).Interior.ColorIndex = 6
End If
Next i
Columns("L:Y").Interior.ColorIndex = xlNone
End With
End Sub
You are specifying the Range.Parent property in your With ... End With statement but ignoring it when it is most important¹.
Sub ColrCls()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("K" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Cells(i, 11).Value = "Non Sen" And .Cells(i, 26).Value = "N/A" Then
.Range("K" & i & ", Z" & i).Interior.ColorIndex = 6
Else
.Range("K" & i & ", Z" & i).Interior.Pattern = xlNone
End If
Next i
End With
End Sub
A Range object to Union discontiguous cells could be one of the following.
.Range("K5, Z5")
Union(.Cells(5, "K"), .Cells(5, "Z"))
In the example above, I've concatenated together a string like the first of these two examples.
¹ See Is the . in .Range necessary when defined by .Cells? for an earnest discussion on this subject.
You could replace
Range(.Cells(i, 11), .Cells(i, 26)).Interior.ColorIndex = 6
with
.Cells(i, 11).Interior.ColorIndex = 6
.Cells(i, 26).Interior.ColorIndex = 6
I want to be able to combine the rows for which the value in the first column matches, so that the values of non-blank cells are consolidated into one row. E.g.:
Mary Smith, A, [blank cell]
Mary Smith, [blank cell], B
-->
Mary Smith A B
I've tried to use the code below:
Dim RowNum As Long, LastRow As Long
Application.ScreenUpdating = False
RowNum = 4
LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
Range("A4", Cells(LastRow, 13)).Select
For Each Row In Selection
With Cells
If Cells(RowNum, 1) = Cells(RowNum + 1, 1) Then
Cells(RowNum + 1, 1).Copy Destination:=Cells(RowNum, 1)
Cells(RowNum + 1, 2).Copy Destination:=Cells(RowNum, 2)
Cells(RowNum + 1, 3).Copy Destination:=Cells(RowNum, 3)
Cells(RowNum + 1, 4).Copy Destination:=Cells(RowNum, 4)
Cells(RowNum + 1, 5).Copy Destination:=Cells(RowNum, 5)
Cells(RowNum + 1, 6).Copy Destination:=Cells(RowNum, 6)
Cells(RowNum + 1, 7).Copy Destination:=Cells(RowNum, 7)
Cells(RowNum + 1, 8).Copy Destination:=Cells(RowNum, 8)
Cells(RowNum + 1, 9).Copy Destination:=Cells(RowNum, 9)
Cells(RowNum + 1, 10).Copy Destination:=Cells(RowNum, 10)
Cells(RowNum + 1, 11).Copy Destination:=Cells(RowNum, 11)
Cells(RowNum + 1, 12).Copy Destination:=Cells(RowNum, 12)
Cells(RowNum + 1, 13).Copy Destination:=Cells(RowNum, 13)
Rows(RowNum + 1).EntireRow.Delete
End If
End With
RowNum = RowNum + 1
Next Row
Application.ScreenUpdating = True
'
End Sub
This does a fine job of consolidating the data so that there are only unique values in the first column, HOWEVER, when the row is copied up, the values of blank cells copy over populated cells, which NOT what I want. So for instance, running this macro on the above data would yield:
Mary Smith, A, [blank cell]
Mary Smith, [blank cell], B
-->
Mary Smith, A, [blank cell]
Any insight into how I might modify the above code (or use something more elegant) would be appreciated!!
This will do it very quickly:
Sub foo()
Dim ws As Worksheet
Dim lstrow As Long
Set ws = Sheets("Sheet1") ' Change to your sheet
With ws
lstrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("B4:M" & lstrow)
.Offset(, 26).FormulaR1C1 = "=IFERROR(INDEX(R4C[-26]:R" & lstrow & "C[-26],MATCH(1,INDEX((R4C1:R" & lstrow & "C1 = RC1)*(R4C[-26]:R" & lstrow & "C[-26] <>""""),),0)),"""")"
ws.Calculate
.Value = .Offset(, 26).Value
.Offset(, 26).ClearContents
End With
With .Range("A4:M" & lstrow)
.Value = .Value
.RemoveDuplicates 1, xlGuess
End With
End With
End Sub
It basically uses the formula: =INDEX(B$4:B$4,MATCH(1,INDEX(($A$4:$A$4 = $A4)*(B$4:B$4 <>""),),0)) To find all the values. Puts those formulas in blank columns and then copies the data back and removes the duplicates.
This will do all 13 columns at once.
It also does not care how many times the value in Column A is repeated. There could be 4 Mary Smiths in that column. It will grab the first value in each column and use that.
Before:
After:
Try the below code
Sub test()
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To LastRow
If ((Range("A" & i).Value = Range("A" & i + 1).Value) And (Range("B" & i).Value <> Range("B" & i + 1).Value) And ((Range("B" & i).Value = "") Or (Range("B" & i + 1).Value = "")) And (Range("C" & i).Value <> Range("C" & i + 1).Value) And ((Range("C" & i).Value = "") Or (Range("C" & i + 1).Value = ""))) Then
If Range("B" & i).Value = "" Then
Range("B" & i).Value = Range("B" & i + 1).Value
ElseIf Range("B" & i + 1).Value = "" Then
Range("B" & i + 1).Value = Range("B" & i).Value
End If
If Range("C" & i).Value = "" Then
Range("C" & i).Value = Range("C" & i + 1).Value
ElseIf Range("C" & i + 1).Value = "" Then
Range("C" & i + 1).Value = Range("C" & i).Value
End If
End If
Range("B" & i).EntireRow.Delete Shift:=(xlUp)
LastRow = LastRow - 1
Next i
End Sub
Here is another approach.
Create a Personnel object. Each Personnel object can have multiple attributes (the non blank column entries in your original table).
By using the Key property of the collection object, and using the Name (column1 data) as the key, we can detect duplicates without having to sort the original data. And the number of attributes for each name is limited only by the size of the worksheet.
Other information is in the comments.
Insert a class object and rename it cPersonnel
Below is the code for the Class and Regular modules
Class Module
Option Explicit
Private pName As String
Private pAttrib As String
Private pAttribs As Collection
Public Property Get Name() As String
Name = pName
End Property
Public Property Let Name(Value As String)
pName = Value
End Property
Public Property Get Attrib() As String
Attrib = pAttrib
End Property
Public Property Let Attrib(Value As String)
pAttrib = Value
End Property
Public Property Get AttribS() As Collection
Set AttribS = pAttribs
End Property
Public Function ADDAttribS(Value As String)
pAttribs.Add Value
End Function
Private Sub Class_Initialize()
Set pAttribs = New Collection
End Sub
Regular Module
Option Explicit
Sub PersonnelAttribs()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes() As Variant
Dim cP As cPersonnel, colP As Collection
Dim LastRow As Long, LastCol As Long
Dim I As Long, J As Long
'Set source and results worksheets, ranges
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
With wsSrc.Cells
LastRow = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastCol = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
End With
'Read source data into array
With wsSrc
vSrc = Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
'create and collect the Personnel objects
'Source data does not need to be sorted
Set colP = New Collection
On Error Resume Next
For I = 1 To UBound(vSrc, 1)
If Trim(vSrc(I, 1)) <> "" Then
Set cP = New cPersonnel
With cP
.Name = vSrc(I, 1)
For J = 2 To UBound(vSrc, 2)
If Trim(vSrc(I, J)) <> "" Then
.Attrib = Trim(vSrc(I, J))
.ADDAttribS .Attrib
End If
Next J
colP.Add cP, .Name
Select Case Err.Number
Case 457 'duplicate name
Err.Clear
For J = 1 To .AttribS.Count
colP(.Name).ADDAttribS .AttribS(J)
Next J
Case Is <> 0
Debug.Print Err.Number, Err.Description
Stop
End Select
End With
End If
Next I
On Error GoTo 0
'Create results array
'Number of columns
For I = 1 To colP.Count
With colP(I)
J = IIf(J > .AttribS.Count, J, .AttribS.Count)
End With
Next I
ReDim vRes(0 To colP.Count, 0 To J)
'Headers
vRes(0, 0) = "Name"
For J = 1 To UBound(vRes, 2)
vRes(0, J) = "Attrib " & J
Next J
'Populate data
For I = 1 To colP.Count
With colP(I)
vRes(I, 0) = .Name
For J = 1 To .AttribS.Count
vRes(I, J) = .AttribS(J)
Next J
End With
Next I
'Clear old data and write new
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2) + 1)
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
Original Data
Results after Macro
I have User form where I have command button and input text box.
I want to copy specified range from one worksheet, then name and paste in another sheet.
My code looks like this, but it is not working.
Private Sub CommandButton1_Click()
Dim i, LastRow
Dim ws As Worksheet
Dim k As Integer
Set ws = Worksheets("Vali")
LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To LastRow 'find fulfiled rows
If Sheets("Sheet1").Cells(i, "D").Value = 1 Then
Sheets("Sheet1").Range(Cells(i, "B"), Cells(i, "D")).Copy Destination:=Sheets("Vali").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
Dim i As Integer
'Next we use a looping process 'We start the loop from row 2 because our worksheet has headers in row 1
For k = 2 To 100
'Now we define a condition that only if there is data under the headers ItemID, Description,
If Cells(k, "A").Value <> "" And Cells(k, "B").Value <> "" And Cells(k, "C").Value <> "" And Cells(k, "D").Value <> "" And Cells(k, "E").Value = "" Then
Cells(k, "D").Value = Me.txtname.Value
End If
Next
Range("E:E").EntireColumn.AutoFit
Range("B4:D21").ClearContents 'clear content on previos sheet, from where we made copy
ActiveWorkbook.Save
ValiFinish.Hide
End Sub
Not sure what you were trying to do with your test on you second loop, because there was no sheet reference, so I choose, let me know if it wasn't that
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim LastRow As Double
Dim ws As Worksheet
Dim Wv As Worksheet
Dim k As Integer
Dim i As Integer
Dim Ti()
ReDim Ti(0)
Dim StartPaste As Double
Dim EndPaste As Double
Dim PastedRange As String
Set ws = Worksheets("Sheet1")
Set Wv = Worksheets("Vali")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
StartPaste = Wv.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
For i = 2 To LastRow
If ws.Cells(i, "D").Value = 1 Then
ws.Range(ws.Cells(i, "A"), ws.Cells(i, "D")).Copy _
Destination:=Wv.Range("A" & Rows.Count).End(xlUp).Offset(1)
Ti(UBound(Ti)) = i
ReDim Preserve Ti(UBound(Ti) + i)
EndPaste = Wv.Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
'2 options because i'm not sur where you want to add the text :
'First one (write on Vali, I think that's what you are looking to do) :
If Wv.Cells(EndPaste, "A").Value <> "" And Wv.Cells(EndPaste, "B").Value <> "" And Wv.Cells(EndPaste, "C").Value <> "" _
And Wv.Cells(EndPaste, "D").Value <> "" And Wv.Cells(EndPaste, "E").Value = "" Then
Wv.Cells(Wv.Range("A" & Rows.Count).End(xlUp).Row, "E").Value = ValiFinish.TxTNaMe.Value
End If
'Second one (write on Sheet1) :
If ws.Cells(i, "A").Value <> "" And ws.Cells(i, "B").Value <> "" And ws.Cells(i, "C").Value <> "" _
And ws.Cells(i, "D").Value <> "" And ws.Cells(i, "E").Value = "" Then
ws.Cells(ws.Range("A" & Rows.Count).End(xlUp).Row, "E").Value = ValiFinish.TxTNaMe.Value
End If
'end of options
End If
Next i
PastedRange = "" & Wv.Name & "!R" & StartPaste & "C1:R" & EndPaste & "C3"
ActiveWorkbook.Names.Add Name:=ValiFinish.TxTNaMe.Value, RefersToR1C1:=PastedRange
'clear content on previous sheet, from where we made copy
For i = LBound(Ti) To UBound(Ti) - 1
ws.Range("$B$" & Ti(i) & ":$D$" & Ti(i)).ClearContents
Next i
Wv.Range("E:E").EntireColumn.AutoFit
Set ws = Nothing
Set Wv = Nothing
ActiveWorkbook.Save
ValiFinish.Hide
Application.ScreenUpdating = True
End Sub