My code below is supposed to filter data in the wsData and then copy it into the wsTest worksheet after each other in column A. The code works except that it copies the values over each on the destination sheet rather then after each other. Any idea why?
Sub PrintReport()
Dim wbFeeReport As Workbook
Dim wsData As Worksheet
Dim wsForm As Worksheet
Dim wsTest As Worksheet
Dim FrRngCount As Range
Dim i As Integer
Dim k As Integer
Dim t As Integer
Dim s As Integer
Set wbFeeReport = Workbooks("FeExcForm.xlsm")
Set wsData = wbFeeReport.Worksheets("Data")
Set wsTest = wbFeeReport.Worksheets("Test")
wsTest.Cells.Clear
wsData.Activate
i = 1
For k = 1 To 2
With ActiveSheet
.AutoFilterMode = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, k
On Error Resume Next
.SpecialCells(xlCellTypeVisible).Copy Destination:=wsTest.Range("A" & i)
End With
i = wsTest.Range("A" & Rows.Count).End(xlUp)
.AutoFilterMode = False
End With
Next k
End Sub
As first point: if using a range with AutoFilter the copy will always exclude the hidden cells
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, k
.Copy wsTest.Range("A" & i)
End With
is all you need here.
Regarding your error: On Error Resume Next hides the error of i = wsTest.Range("A" & Rows.Count).End(xlUp) which would return a range rather than a numerical value.
i = wsTest.Range("A" & Rows.Count).End(xlUp).Row + 1
is your friend here :)
Everything together should look something like that:
Sub PrintReport()
Dim wbFeeReport As Workbook
Dim wsData As Worksheet
Dim wsForm As Worksheet
Dim wsTest As Worksheet
Dim FrRngCount As Range
Dim i As Integer
Dim k As Integer
Dim t As Integer
Dim s As Integer
Set wbFeeReport = Workbooks("FeExcForm.xlsm")
Set wsData = wbFeeReport.Worksheets("Data")
Set wsTest = wbFeeReport.Worksheets("Test")
wsTest.Cells.Clear
wsData.Activate
i = 1
For k = 1 To 2
With wsData
.AutoFilterMode = False
With .Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, k
.Copy wsTest.Range("A" & i)
End With
i = wsTest.Range("A" & Rows.Count).End(xlUp).Row + 1
.AutoFilterMode = False
End With
Next k
End Sub
EDIT: For excluding headers just change:
.Copy wsTest.Range("A" & i)
to:
If i = 1 Then .Copy wsTest.Range("A" & i) Else .Offset(1, 0).Copy wsTest.Range("A" & i)
and if you do not want any headers at all then directly use:
.Offset(1, 0).Copy wsTest.Range("A" & i)
But I havent tested it. Just tell me if you get any problems ;)
Related
I created a macro that fills the missing Data with specific Data from another sheet , the codes works perfectly in copying pasting data from excel of the client and prepare the data needed to start the work but the only problem here below
Code:
With Worksheets("Feuil2")
' reference "target" sheet (change "Target" to our actual target sheet name)
With .Range("B1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row) 'reference
its column B range from row 1 down to last not empty one
If WorksheetFunction.CountBlank(.Cells) > 0 Then
' if any blank cell in referenced range. this check to avoid error thrown by subsequent
statament
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=index(GDC!" & rng.Offset(, 1).Address(, , xlR1C1) & ",match(RC[-1],GDC!" & rng.Address(, , xlR1C1) & ",0))" 'fill blank cells with a lookup (well, sort of) formula
.Value = .Value 'get rid of formulas and leave values only
Cells.Select
End If
End With
End With
This code works perfectly in matching and filling data but when for e.g find a duplicated value it copy only the first value not the second one
See the image below to better understand the main problem :
As you can see in the image The problem that in column A i may have data repeated twice like this value P20845 which in column F it is repeated one with the name of Ghaith and the other with the name of sirine but as you can see in the column A it is just with the name also of Ghaith and there is no name of sirine
Anyidea or better solution in solving this and getting all the needed DATA? .
Best Regards
POLOS
Or use a dictionary
Option Explicit
Public Sub AddValues()
Application.ScreenUpdating = False
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet, masterDict As Object, arr() As Variant, i As Long, rng As Range
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Feuil1")
Set wsTarget = wb.Worksheets("Feuil2")
Set masterDict = CreateObject("Scripting.Dictionary")
With wsSource
arr = Intersect(.Columns("A:B"), .UsedRange)
For i = 1 To UBound(arr, 1)
If Not masterDict.exists(arr(i, 1)) Then masterDict.Add arr(i, 1), GetAllMatches(arr(i, 1), arr(i, 2), wsSource)
Next i
End With
With wsTarget
For Each rng In Intersect(.Columns("A"), .UsedRange)
On Error Resume Next
rng.Offset(, 1) = masterDict(rng.Value)
On Error GoTo 0
Next rng
End With
Application.ScreenUpdating = True
End Sub
Public Function GetAllMatches(ByVal findString As String, ByVal dupString As String, ByVal searchRng As Worksheet) As String
Dim foundCell As Range
Dim concatenatedString As String
concatenatedString = vbNullString
With Intersect(searchRng.Columns(1), searchRng.UsedRange)
Set foundCell = .Find(findString)
If foundCell Is Nothing Then Exit Function
If Not foundCell Is Nothing Then concatenatedString = foundCell.Offset(, 1)
Dim currMatch As Long
currMatch = 0
For currMatch = 1 To WorksheetFunction.CountIf(.Cells, findString)
Set foundCell = .Find(What:=findString, After:=foundCell, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not foundCell Is Nothing And InStr(1, dupString, concatenatedString) = 0 Then
concatenatedString = concatenatedString & "/" & foundCell.Offset(, 1)
Else
concatenatedString = foundCell.Offset(, 1)
End If
Next currMatch
End With
GetAllMatches = concatenatedString
End Function
Output in Feuil2
Maybe something like this instead?
Sub Test()
Dim i As Long, myrow As Long, lastrow As Long
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
lastrow = 1
For i = 1 To 7
If Application.WorksheetFunction.CountIf(sht1.Range("A:A"), sht2.Range("F" & i).Value) = 0 Then
If i = 1 Then
lastrow = 1
Else
lastrow = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row + 1
End If
sht1.Range("A" & lastrow).Value = sht2.Range("F" & i).Value
sht1.Range("B" & lastrow).Value = sht2.Range("G" & i).Value
Else
sht1.Range("B" & sht1.Columns("A:A").Find(What:=sht2.Range("F" & i).Value).Row).Value = sht1.Range("B" & sht1.Columns("A:A").Find(What:=sht2.Range("F" & i).Value).Row).Value & "/" & sht2.Range("G" & i).Value
End If
Next i
End Sub
I have two worksheets, "Signed" and "April". I want to copy Column "Y" from "Signed" based on certain criteria into column "A" of "April" starting from the next available/blank row. ( so right under the existing data).
My criteria for column Y is that if column L = month of cell "D2" from "April" AND the year of cell "D2" from "ApriL"...( so right now D2 is 4/30/2017).. then copy that cell in the next available row of Col A of "April" and keep adding on.
I've been trying several different things but just am not able to get it..any idea on how I can achieve this?
My code is below:
Set sourceSht = ThisWorkbook.Worksheets("Signed")
Set myRange = sourceSht.Range("Y1", Range("Y" & Rows.Count).End(xlUp))
Set ws2 = Sheets(NewSheet)
DestRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1
For Each rw In myRange.Rows
If rw.Cells(12).Value = "Month(Sheets(ws2).Range("D2"))" Then
myRange.Value.Copy Destinations:=Sheets(ws2).Range("A" & DestRow)
End If
Something like this should work for you:
Sub tgr()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim aData As Variant
Dim aResults() As Variant
Dim dtCheck As Date
Dim lCount As Long
Dim lResultIndex As Long
Dim i As Long
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Signed") 'This is your source sheet
Set wsDest = wb.Sheets("April") 'This is your destination sheet
dtCheck = wsDest.Range("D2").Value2 'This is the date you want to compare against
With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row)
lCount = WorksheetFunction.CountIfs(.Resize(, 1), ">=" & DateSerial(Year(dtCheck), Month(dtCheck), 1), .Resize(, 1), "<" & DateSerial(Year(dtCheck), Month(dtCheck) + 1, 1))
If lCount = 0 Then
MsgBox "No matches found for [" & Format(dtCheck, "mmmm yyyy") & "] in column L of " & wsData.Name & Chr(10) & "Exiting Macro"
Exit Sub
Else
ReDim aResults(1 To lCount, 1 To 1)
aData = .Value
End If
End With
For i = 1 To UBound(aData, 1)
If IsDate(aData(i, 1)) Then
If Year(aData(i, 1)) = Year(dtCheck) And Month(aData(i, 1)) = Month(dtCheck) Then
lResultIndex = lResultIndex + 1
aResults(lResultIndex, 1) = aData(i, UBound(aData, 2))
End If
End If
Next i
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lCount).Value = aResults
End Sub
Alternate method using AutoFilter instead of iterating over an array:
Sub tgrFilter()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim dtCheck As Date
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Signed") 'This is your source sheet
Set wsDest = wb.Sheets("April") 'This is your destination sheet
dtCheck = wsDest.Range("D2").Value2 'This is the date you want to compare against
With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row)
.AutoFilter 1, , xlFilterValues, Array(1, Format(WorksheetFunction.EoMonth(dtCheck, 0), "m/d/yyyy"))
Intersect(.Cells, .Parent.Columns("Y")).Offset(1).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
.AutoFilter
End With
End Sub
Here's a generic script which you can easily modify to handle almost ANY criteria, as needed.
Sub Copy_If_Criteria_Met()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Sheet1").Range("A1:A" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
If CStr(xCell.Value) = "X" Then
xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
xCell.EntireRow.Delete
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I've a strange problem.
the following code will run using F8 or pressing the run button on the development module.
But when added to the excel ribbon as a macro by the following process the vlookup will return #N/A :
1.right click on the excel toolbar > customize the ribbon
choose macro commands
add it to a new group.
the code is :
Sub Compare()
'set primary Workbook
'find last cell'
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Sheet1")
With WS
Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
LastCellRowNumber = LastCell.Row
'MsgBox (LastCell.Row)
End With
'Adding Index Column
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
[A2].Formula = "=G2&H2"
Range("A2:A" & LastCellRowNumber).FillDown
'adding headers
[Ag1].Value = "Resale"
[Ah1].Value = "Cost"
[Ai1].Value = "disti"
'set primary Workbook
Dim Pri As Workbook
Set Pri = ActiveWorkbook
'open company quotes
Workbooks.Open ("R:\company\DATA\company quotes.xlsx")
'find last cell'
Dim WSq As Worksheet
Dim LastCellq As Range
Dim LastCellRowNumberq As Long
Set WSq = Worksheets("Quote Summary")
With WSq
Set LastCellq = .Cells(.Rows.Count, "A").End(xlUp)
LastCellRowNumberq = LastCellq.Row
'MsgBox (LastCell.Row)
End With
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Dim quotes As Workbook
Set quotes = ActiveWorkbook
[A2].Formula = "=J2&B2"
Range("A2:A" & LastCellRowNumberq).FillDown
Pri.Activate
Dim i As Integer
For i = 2 To LastCellRowNumber
Dim result As String
Dim sheet As Worksheet
Range("AG" & i) = Application.VLookup(Sheet1.Range("A" & i), Workbooks("company quotes.xlsx").Worksheets("Quote Summary").Range("A2:AS" & LastCellRowNumberq), 17, False)
Range("AH" & i) = Application.VLookup(Sheet1.Range("A" & i), Workbooks("company quotes.xlsx").Worksheets("Quote Summary").Range("A2:AS" & LastCellRowNumberq), 19, False)
Range("Ai" & i) = Application.VLookup(Sheet1.Range("A" & i), Workbooks("company quotes.xlsx").Worksheets("Quote Summary").Range("A2:AS" & LastCellRowNumberq), 20, False)
Next i
End Sub
I've tried to fix any referencing issues I could find but you'll need to have a look through and make sure all of the Range references are prefixed with the correct Workbook and Worksheet as it wasn't too clear which worksheet they were coming from in the original code:
Sub Compare()
'Set primary Workbook
'Find last cell
Dim WS As Worksheet
Dim LastCellRowNumber As Long
Set WS = ThisWorkbook.Sheets("Sheet1")
LastCellRowNumber = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
'MsgBox (LastCell.Row)
'Adding Index Column
WS.Columns("A:A").Insert Shift:=xlToRight
WS.Range("A2:A" & LastCellRowNumber).Formula = "=G2&H2"
'adding headers
WS.Range("AG1").Value = "Resale"
WS.Range("AH1").Value = "Cost"
WS.Range("AI1").Value = "disti"
'open company quotes
Dim wbCompQuotes As Workbook
Set wbCompQuotes = Workbooks.Open ("R:\company\DATA\company quotes.xlsx")
'find last cell'
Dim wsQuoteSum As Worksheet
Dim LastCellRowNumberq As Long
Set wsQuoteSum = wbCompQuotes.Worksheets("Quote Summary")
LastCellRowNumberq = wsQuoteSum.Cells(wsQuoteSum.Rows.Count, "A").End(xlUp).Row
'MsgBox (LastCell.Row)
wsQuoteSum.Columns("A:A").Insert Shift:=xlToRight
wsQuoteSum.Range("A2:A" & LastCellRowNumberq).Formula = "=J2&B2"
Dim i As Long
For i = 2 To LastCellRowNumber
WS.Range("AG" & i) = Application.VLookup(WS.Range("A" & i), wsQuoteSum.Range("A2:AS" & LastCellRowNumberq), 17, False)
WS.Range("AH" & i) = Application.VLookup(WS.Range("A" & i), wsQuoteSum.Range("A2:AS" & LastCellRowNumberq), 19, False)
WS.Range("AI" & i) = Application.VLookup(WS.Range("A" & i), wsQuoteSum.Range("A2:AS" & LastCellRowNumberq), 20, False)
Next i
End Sub
This code to is to search each element from column A in worksheet 6 to be existing in Column A in worksheet 3
Sub checkpanvalueS()
Dim lastRow1 As Long
Dim lastRow2 As Long
lastRow1 = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row
lastRow2 = Sheet6.Cells(Rows.Count, 1).End(xlUp).Row
Dim myArr As Variant
'Dim myArr2 As Variant
'For i = 2 To lastRow1
'myArr(i) = Sheet3.Cells(i, 1)
myArr = Sheet3.Range("A2:A" & lastRow1)
'myArr2 = Sheet6.Range("A2:A" & lastRow2)
'Next i
' For i = 2 To lastRow1
For m = 2 To lastRow2
'if UBound(Filter(myArr, Sheet6.Cells(m, 1))) > -1 and then
' MsgBox "All Yellow highlighted pan number (Column A ) should not be one from ptimary Cards ."
' If UBound(Filter(myArr, myArr(i))) >= 0 And myArr(i) <> "" Then
' If IsInArray(Sheet6.Cells(m, 1), myArr) Then
If Filter(myArr, Sheet6.Cells(m, 1)) = "" Then
' MsgBox ("Search Term SUCCESSFULLY located in the Array")
Range("A" & m).Interior.Color = vbYellow
MsgBox (" These pan numbers should'nt be equal to existing primary cards")
End If
Next m
' Next i
End Sub
Try this code - you should use the Find method of the Range object to look for a specific value:
Public Sub HighlightItems()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rngSearch1 As Range
Dim rngSearch2 As Range
Dim rngCell As Range
Dim rngFound As Range
Set ws1 = ThisWorkbook.Worksheets("Sheet6")
Set ws2 = ThisWorkbook.Worksheets("Sheet3")
Set rngSearch1 = ws1.Range("A1:A" & ws1.Cells(Rows.Count, 1).End(xlUp).Row)
Set rngSearch2 = ws2.Range("A1:A" & ws1.Cells(Rows.Count, 1).End(xlUp).Row)
For Each rngCell In rngSearch1
Set rngFound = rngSearch2.Find(rngCell.Value)
If Not rngFound Is Nothing Then
rngCell.Interior.Color = vbYellow
Debug.Print ws1.Name & "!" & rngCell.Address & " equals " & ws2.Name & "!" & rngFound.Address
End If
Next
End Sub
I have two sheets. I want to check the value in one column against the value in the same column in the second sheet. If they match, then I want to migrate the string data from the Notes column to the new sheet. (essentially I'm seeing if last week's ticket numbers are still valid this week, and carrying over the notes from last week).
I am trying to do this with the following code (using columns Z for the data, BE for the notes):
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Dim partNo2 As Range
Dim partNo1 As Range
Dim partNo3 As Range
For Each partNo2 In ws1.Range("Z1:Z" & ws1.Range("Z" & Rows.Count).End(xlUp).Row)
For Each partNo1 In ws2.Range("Z1:Z" & ws2.Range("Z" & Rows.Count).End(xlUp).Row)
For Each partNo3 In ws1.Range("BE1:BE" & ws2.Range("BE" & Rows.Count).End(xlUp).Row)
If StrComp(Trim(partNo2), Trim(partNo1), vbTextCompare) = 0 Then
ws2.Range("BE" & partNo1.Row) = partNo3
End If
Next
Next
Next
'now if no match was found then put NO MATCH in cell
For Each partNo1 In ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If IsEmpty(partNo1) Then partNo1 = ""
Next
End Sub
Untested:
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim c As Range, f As Range
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set rng1 = ws1.Range("Z1:Z" & ws1.Range("Z" & Rows.Count).End(xlUp).Row)
Set rng2 = ws2.Range("Z1:Z" & ws2.Range("Z" & Rows.Count).End(xlUp).Row)
For Each c In rng1.Cells
Set f = rng2.Find(c.Value, , xlValues, xlWhole)
If Not f Is Nothing Then
f.EntireRow.Cells(, "BE").Value = c.EntireRow.Cells(, "BE").Value
End If
Next c
'now if no match was found then put NO MATCH in cell
For Each c In ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If Len(c.Value) = 0 Then c.Value = "NO MATCH"
Next
End Sub
This accomplishes the same result (maybe with the exception of the columns E & F at the bottom with NO MATCH). It's just a different way of going about it. Instead of using ranges, I'm just looking at each cell and comparing it directly.
TESTED:
Sub NoteMatch()
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim tempVal As String
lastRow1 = Sheets("Sheet1").Range("Z" & Rows.Count).End(xlUp).row
lastRow2 = Sheets("Sheet2").Range("Z" & Rows.Count).End(xlUp).row
For sRow = 2 To lastRow1
tempVal = Sheets("Sheet1").Cells(sRow, "Z").Text
For tRow = 2 To lastRow2
If Sheets("Sheet2").Cells(tRow, "Z") = tempVal Then
Sheets("Sheet2").Cells(tRow, "BE") = Sheets("Sheet1").Cells(sRow, "BE")
End If
Next tRow
Next sRow
Dim match As Boolean
'now if no match was found, then put NO MATCH in cell
For lRow = 2 To lastRow2
match = False
tempVal = Sheets("Sheet2").Cells(lRow, "Z").Text
For sRow = 2 To lastRow1
If Sheets("Sheet1").Cells(sRow, "Z") = tempVal Then
match = True
End If
Next sRow
If match = False Then
Sheets("Sheet2").Cells(lRow, "BE") = "NO MATCH"
End If
Next lRow
End Sub