VBA code to loop through different sheets and take specific columns - excel

I am hoping someone can share their knowledge and be of assistance.
I am trying to loop through DataSheet1, DataSheet2..... and take certain columns from each sheet.
I am sure this question has been asked before - my attempt at code is below.
I attempted to do it for one column but I got stuck in an infinite loop.
any help is greatly appreciated.
Sub SummarySheet()
Dim WKSheetSummarySheet As Worksheet, WKSheetDataSheet1 As Worksheet, WKSheetDataSheet2 As Worksheet, WKSheetDataSheet3 As Worksheet, WKSheetDataSheet4 As Worksheet
Dim LastRowSummarySheet As Long, LastRowDataSheet1 As Long, LastRowDataSheet2 As Long, LastRowDataSheet3 As Long, LastRowDataSheet4 As Long
Dim LastColSummarySheet As Long, LastColDataSheet1 As Long, LastColDataSheet2 As Long, LastColDataSheet3 As Long, LastColDataSheet4 As Long
Dim RangeSummarySheet As Range, RangeDataSheet1 As Range, RangeDataSheet2 As Range, RangeDataSheet3 As Range, RangeDataSheet4 As Range
Set WKSheetSummarySheet = ThisWorkbook.Worksheets("SummarySheet")
Set WKSheetDataSheet1 = ThisWorkbook.Worksheets("DataSheet1")
Set WKSheetDataSheet2 = ThisWorkbook.Worksheets("DataSheet2")
Set WKSheetDataSheet3 = ThisWorkbook.Worksheets("DataSheet3")
Set WKSheetDataSheet4 = ThisWorkbook.Worksheets("DataSheet4")
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlManual
End With
On Error Resume Next
LastRowSummarySheet = WKSheetSummarySheet.Cells(WKSheetSummarySheet.Rows.Count, 1).End(xlUp).Row
LastRowDataSheet1 = WKSheetDataSheet1.Cells(WKSheetDataSheet1.Rows.Count, 1).End(xlUp).Row
LastRowDataSheet2 = WKSheetDataSheet2.Cells(WKSheetDataSheet2.Rows.Count, 1).End(xlUp).Row
LastRowDataSheet3 = WKSheetDataSheet3.Cells(WKSheetDataSheet3.Rows.Count, 1).End(xlUp).Row
LastRowDataSheet4 = WKSheetDataSheet4.Cells(WKSheetDataSheet4.Rows.Count, 1).End(xlUp).Row
LastColSummarySheet = WKSheetSummarySheet.Cells(1, WKSheetSummarySheet.Columns.Count).End(xlToLeft).Column
LastColDataSheet1 = WKSheetDataSheet1.Cells(1, WKSheetDataSheet1.Columns.Count).End(xlToLeft).Column
LastColDataSheet2 = WKSheetDataSheet2.Cells(1, WKSheetDataSheet2.Columns.Count).End(xlToLeft).Column
LastColDataSheet3 = WKSheetDataSheet3.Cells(1, WKSheetDataSheet3.Columns.Count).End(xlToLeft).Column
LastColDataSheet4 = WKSheetDataSheet4.Cells(1, WKSheetDataSheet4.Columns.Count).End(xlToLeft).Column
Set RangeSummarySheet = Range(RangeSummarySheet.Cells(3, 2), RangeSummarySheet.Cells(LastRowSummarySheet, LastColSummarySheet))
Set RangeDataSheet1 = Range(RangeDataSheet1.Cells(5, 1), RangeDataSheet1.Cells(LastRowDataSheet1, LastColDataSheet1))
Set RangeDataSheet2 = Range(RangeDataSheet2.Cells(5, 1), RangeDataSheet2.Cells(LastRowDataSheet2, LastColDataSheet2))
Set RangeDataSheet3 = Range(RangeDataSheet3.Cells(5, 1), RangeDataSheet3.Cells(LastRowDataSheet3, LastColDataSheet3))
Set RangeDataSheet4 = Range(RangeDataSheet4.Cells(5, 1), RangeDataSheet4.Cells(LastRowDataSheet4, LastColDataSheet4))
Do Until IsEmpty(RangeDataSheet1(1))
RangeDataSheet1(1) = RangeSummarySheet(1)
Set RangeDataSheet1 = RangeDataSheet1.Offset(1, 0)
Set RangeSummarySheet = RangeSummarySheet.Offset(1, 0)
Loop
End Sub

I tried to decipher what you wanted to accomplish; if this code is not correct please clarify what you are trying to accomplish and provide and example of the data. This basic code below will loop through your four DataSheets copy the range from "A5" to the lastrow and lastcolumn, and then paste in the SummarySheet into the next empty row for each loop. Comments are added in the code.
Side note: when using the 'Equals' method, the source and destination range must be the same.
Sub ConsolidateSheetDataInSumSheet()
'This code will copy the range starting at "A5" to the lastrow and lastcolumn from each `DataSheet`,
'and paste to the next empty cell in `Column 2` in the 'SummarySheet'
Dim wsSum As Worksheet: Set wsSum = ThisWorkbook.Sheets("SummarySheet") 'Define the SummmarySheet variable
For x = 1 To 4 'Loop from 1 to 4 (the number for each datasheet)
With ThisWorkbook.Sheets("DataSheet" & x) 'DataSheet1, DataSheet2, etc.
'The next line sets the range from for each `DataSheet`, copies the range and
'pastes the copied range to the next empty cell in the `SummarySheet`
'the line is separated using the Dash, `_`, for ease of reading
.Range(.Cells(5, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column)).Copy _
wsSum.Cells(Rows.Count, 2).End(xlUp).Offset(1)
End With
Next x 'Go to next `DataSheet`
End Sub

Related

Compare two arrays with two conditions

I have two sheets, call worksheet1 = GoldCopy and worksheet2 = OPS, both with several of the same columns:
column 1 = Filename, column 3 = file path, column 4 = encryption code, and column 5 = in goldcopy (or OPS depending on which ws you're looking at).
There are 10,000+ rows of data. I want to compare ws1 with ws2 and make sure the filename and encryption code from ws1 is in ws2 (doesn't matter where as long as filename and encryption code are in the same row).
If there is a filename and encryption code that is not in ws2, then that column 5 at that row will be made FALSE.
Then I want to compare ws2 to ws1 with the same logic.
I tried two for loops but it has taken forever to finish. I want to try arrays. I'm having trouble with the 'IF' statements which I will label below.
This is the first part of the code with ws1 checking ws2. I assume to have ws2 check against ws1, it would be the same code, just switched around.
Sub CheckforDiscrepancies
Application.ScreenUpdating = False
Dim s As Worksheet
For Each s In Sheets
'NEW FILE SEARCH A-NAS OPS'
If s.Name = "OPS" Then 'check if there is an OPS file if so then proceed'
ACOL = Worksheets("OPS").Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets("OPS").Cells(1, ACOL + 1).Value = "In Gold Copy?"
'GoldCopy Check with OPS'
Worksheets("GoldCopy").Activate
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets("GoldCopy").Cells(1, GCOL + 1) = "Deployed in OPS?"
Dim arrayGoldRow As Variant
Dim arrayGoldRow2 As Variant
Dim arrayARow As Variant
Dim arrayARow2 As Variant
arrayGoldRow = Worksheets("GoldCopy").Range("A:A").Value 'this should be column 1 the filename for the goldcopy
arrayARow = Worksheets("OPS").Range("A:A").Value 'this should be column 1 for the filename for the ops sheet
arrayGoldRow2 = Worksheets("GoldCopy").Range("D:D").Value 'this should be column 4 for the encryption code for the goldcopy
arrayARow2 = Worksheets("OPS").Range("D:D").Value 'this should be column 4 for the encryption code for the ops sheet
For i = LBound(arrayGoldRow, 1) To UBound(arrayGoldRow, 1)
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
If InStr(Worksheets("GoldCopy").Cells(i, 3), "\sidata\") > 0 Then 'this is checking column 3 to see if the filepath fits a certain criteria
For x = LBound(arrayARow, 1) To UBound(arrayARow, 1) 'not sure if this is correct of not
If Worksheets("GoldCopy").Cells(i,1) = Worksheets("OPS").Cells(j,1) and Worksheets("GoldCopy").Cells(j,4) = Worksheets("OPS").Cells(j,4) Then 'this is saying is filename in column1 and encyrption code in column2 from the goldcopy BOTH match with the filename in column1 and encyrption code in column2 from the ops sheet, then...
bln = True
Worksheets("GoldCopy").Cells(i, GCOL) = bln
Worksheets("GoldCopy").Cells(i, GCOL).Interior.ColorIndex = 10
Exit For
Else
Worksheets("GoldCopy").Cells(i, GCOL) = bln
Worksheets("GoldCopy").Cells(i, GCOL).Interior.ColorIndex = 22
End If
Next x
End If
Next i
This is the way I would tackle the task. Please try my code. It uses the COUNTIFS worksheet function to check if the combination of file and code exists. You could extend this to include the path. It also uses the same function, called with file names reversed, to check availability both ways.
Enum Nws ' worksheet parameters
' 118
NwsFirstDataRow = 2 ' change to suit
NwsFile = 1 ' columns: 1 = column A
NwsPath = 3 ' 3 = column C
NwsCode ' no value assigned means previous + 1
NwsCheck
End Enum
Sub CompareTabs()
' 118
Dim WsOps As Worksheet
Dim WsGold As Worksheet
On Error Resume Next
Set WsOps = Worksheets("OPS")
Set WsGold = Worksheets("GoldCopy")
If Err Then Exit Sub ' exit if one of the sheets doesn't exist
On Error GoTo 0
Application.ScreenUpdating = False
Debug.Print MarkDiscrepancies(WsOps, WsGold)
Debug.Print MarkDiscrepancies(WsGold, WsOps)
Application.ScreenUpdating = False
End Sub
Private Function MarkDiscrepancies(Ws1 As Worksheet, _
Ws2 As Worksheet) As Boolean
' 118
' return True if a discrepancy was found and marked
Dim Src As Variant ' Source = base data
Dim Scode As Variant ' Src encryption codes
Dim Tgt As Range ' Target = range to find Src data in
Dim Tcode As Range ' Tgt encryption codes
Dim R As Long ' loop counter: rows in Ws1
With Ws2
Set Tgt = .Range(.Cells(1, NwsFile), .Cells(.Rows.Count, NwsFile).End(xlUp))
End With
Set Tcode = Tgt.Offset(, NwsCode - NwsFile)
With Ws1
Src = .Range(.Cells(1, NwsFile), .Cells(.Rows.Count, NwsFile).End(xlUp)).Value
Scode = .Range(.Cells(1, NwsFile), .Cells(.Rows.Count, NwsFile).End(xlUp)) _
.Offset(, NwsCode - NwsFile).Value
For R = NwsFirstDataRow To UBound(Src)
On Error Resume Next
.Cells(R, NwsCheck).Value = CBool(WorksheetFunction.CountIfs(Tgt, Src(R, 1), Tcode, Scode(R, 1)))
Next R
MarkDiscrepancies = CBool(WorksheetFunction.CountIf( _
.Range(.Cells(NwsFirstDataRow, NwsCheck), _
.Cells(.Rows.Count, NwsCheck).End(xlUp)), False))
End With
End Function
The function that does the work returns True or False, depending upon whether discrepancies were found. It prints the result to the Immediate Pane. You might show it in a MsgBox or just call the function like a sub (without parentheses) and take your information from column E - as, in fact, does my code.

Move rows to different excelfiles matching multiple cellvalues per file

I would like to be able to move the rows of a large-ish excel file into different excel files. Multiple matching cell values from a single column in the source file will need to be moved to each destination file. I would like to do this in an easily extensible way since there will be an increasing number of cell value and destination file pairs in the future.
In my current implementation I first move the rows to separate sheets, one for each destination file and later make separate files from each sheets, that part of the code works well and for brevity I have not included it in this question.
So far I have tried using the following for moving the rows to their respctive new worksheets, and it works but has made for lots of redundancies in the code. I have included a code sample using just one pair, "PRE Name1*" which goes in the sheet "Destfile1", in my current project I have the big code block repeated for every pair, which makes the project not very easy to work with. The first part of the pair, that matches the cell value is using wildcard matching since most of the values have common prefixes in their names.
Sub SplitOnCellvalues()
Dim xRg As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Source").UsedRange.Rows.Count
J = Worksheets("Destfile1").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Destfile1").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Source").Range("O1:O" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) Like "PRE Name1*" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Destfile1").Range("A" & J + 1)
xRg(K).EntireRow.Delete
K = K - 1
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I currently also have a separate sub that pre-creates the sheets so it is safe to assume they exist.
I have also tried to build a multidimensional array that I could iterate over instead, but I can't seem to find a good way to build the array that feels like it will scale well when the list of pairs grow larger.
To illustrate the list of matching cell values and destination sheets they need to be moved to looks similar to this
"PRE Name1*" "Destfile1111"
"PRE Name2*" "DestfileAAAA"
"PRE AAAAA*" "Destfile1111"
"PRE DDDDD*" "Destfile2222"
"PRE Name4*" "DestfileAAAA"
"PRE Name4*" "DestfileAAAA"
I am mostly looking for a way to do this with fairly clean and extensible code as this project will need to be amended with new pairs of cell values and destination files on at least a monthly basis for the foreseeable future.
This code should do what you want. It doesn't delete the source range though.
I haven't added the * wildcard to the end of each value. It gets added during the filter.
Option Explicit
Public Sub SplitOnCellValues()
Dim MatchesArray() As Variant
MatchesArray = Array("PRE Name1", "Destfile1111", _
"PRE Name2", "DestfileAAAA", _
"PRE AAAAABV", "Destfile1111", _
"ABC", "Destfile1234")
Dim SourceSheet As Worksheet
Set SourceSheet = ThisWorkbook.Worksheets("Source")
'Make sure the source sheet isn't filtered and set a range
'to the data including and excluding headers.
With SourceSheet
If .AutoFilterMode Then .AutoFilterMode = False
Dim SourceLastCell As Range
Set SourceLastCell = LastCell(SourceSheet)
Dim SourceRange As Range
Set SourceRange = .Range(.Cells(1, 1), SourceLastCell)
Dim SourceData As Range
Set SourceData = .Range(.Cells(2, 1), SourceLastCell)
End With
'Loop through the array and filter the source data.
'If data is found then copy the visible rows to the bottom of the required sheet.
Dim TargetLastCell As Range
Dim TargetSheet As Worksheet
Dim x As Long
For x = LBound(MatchesArray) To UBound(MatchesArray) Step 2
SourceRange.AutoFilter Field:=15, Criteria1:=MatchesArray(x) & "*"
If SourceRange.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
Set TargetSheet = ThisWorkbook.Worksheets(MatchesArray(x + 1))
Set TargetLastCell = LastCell(TargetSheet)
SourceData.SpecialCells(xlCellTypeVisible).Copy _
Destination:=TargetSheet.Cells(TargetLastCell.Row + 1, 1)
End If
Next x
End Sub
'Find the last cell on a sheet. Returns A1 if the sheet is empty.
Public Function LastCell(wrkSht As Worksheet) As Range
Dim LastCol As Long, LastRow As Long
On Error Resume Next
With wrkSht
LastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
End With
If LastCol = 0 Then LastCol = 1
If LastRow = 0 Then LastRow = 1
Set LastCell = wrkSht.Cells(LastRow, LastCol)
On Error GoTo 0
End Function

If statement for two values for large set of data

I struggle with VBA and have spent a few days trying to find a solution to this problem. Essentially, I have two spreadsheets with large sets of data. Column K of "Design Mods" worksheet contains the same types of values as Column C of the "Output" Worksheet. I've been trying to get my script to do the following:
1. for each cell in column k of "Design Mods", check if there is a matching cell in column c of the "output" spreadsheet
2. if a match is found, then populate the cell in "Design Mods" to columns over with the information from column b of "Output"
Because of my lack of experience, I've only been able to setup the script below which only checks and pulls correctly for one cell.
I need it to check each cell against a range of other cells.
Any help/guidance would be very much appreciated.
Thank you very much!
Sub MatchValue_Test()
'Routine is meant to populate columns "Design Mods" Spreadsheet with affected calculations from the "Output" Spreadsheet
'Variables below refer to Design Mods spreadsheet
Dim designmod As Worksheet '<-- Design Mods worksheet that we are comparing to the Output Data
Dim DesignMod_DClrow As Integer '<-- Variable used to count to the last low in the DC Number Column of Design Mods Spreadsheet
Dim designmoddc As Range '<-- Variable used to identify the range of values being checked in Design Mods is the DC Numbers Column K from K4 to the end of the column
Dim valuetofind As String '<-- DC Number used as matching criteria between Design Mods spreadsheet and Output Data
'Test Variables for integrating references to from Output worksheet
Dim testset As Worksheet
Dim test2_lrow As Integer
Dim test As Range
Dim valuetofindw2 As String
'Variables below pertain the routine itself
Dim found As Boolean '<-- this condition has to be false to start the routine
'Start of Routine
found = False
'Definition of Data Ranges in Design Mods spreadsheet
Set designmod = ActiveWorkbook.Worksheets("Sheet1")
DesignMod_DClrow = designmod.Range("K4").End(xlDown).Row
Set designmoddc = designmod.Range("K4:K" & DesignMod_DClrow)
'Test variables for integrating values from Output worksheet
Set testset = ActiveWorkbook.Worksheets("Sheet2")
test2_lrow = testset.Range("C2").End(xlDown).Row
Set test = testset.Range("C2:C" & test2_lrow)
'Identify the value being matched against
valuetofind = designmod.Range("L4").Value '<-- the script wont run if I have this value set to a range, and I need to figure out get this to loop so I don't need a variable for every cell im checking against
'test variables to figure out if statement
valuetofindw2 = testset.Range("C2").Value
valuetofindw3 = testset.Range("B2").Value
valuetofindw4 = designmod.Range("K4")
'If Statements performing the comparison
For Each Cell In designmoddc
If Cell.Value = valuetofindw3 Then
found = True
End If
Next
If found = True Then
designmoddc.Cells.Offset(0, 2).Value = testset.Range("B2")
End If
End Sub
You did not answer my clarification questions...
I prepared a solution, able to work very fast (using arrays). Please back-up your workbook, because the code will rewrite the matching cases in column M:M.
Sub MatchValue_TestArrays()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, boolFound As Boolean
Set designMod = Worksheets("Sheet1")
Set testSet = Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:M" & lastRowD).value 'load the range in array
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, 3) = arrTest(t, 1)'fill the array third column (M:M) with values of B:B testSheet...
Exit For
End If
Next t
Next d
designMod.Range("K4:M" & lastRowD).value = arrDes' Drop the modified array
End Sub
Try the updated code, please. It searches now for all occurrences and put each one in a consecutive column:
Sub MatchValue_TestArrays_Extended()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, col As Long
Set designMod = Worksheets("Design") ' Worksheets("Sheet1")
Set testSet = Worksheets("TestS") ' Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:AQ" & lastRowD).value
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
col = 3 'the column where the occurrence will be put
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, col) = arrTest(t, 1): col = col + 1
End If
Next t
Next d
designMod.Range("K4:AQ" & lastRowD).value = arrDes
End Sub
Using Match() is fast when your data is on a worksheet:
Sub MatchValue_Test()
Dim wsDesign As Worksheet, wsOut As Worksheet, m, c As Range
Set wsDesign = ActiveWorkbook.Worksheets("Sheet1")
Set wsOut = ActiveWorkbook.Worksheets("Sheet2")
For Each c In wsDesign.Range(wsDesign.Range("K4"), _
wsDesign.Cells(Rows.Count, "k").End(xlUp)).Cells
m = Application.Match(c.Value, wsOut.Columns("C"), 0)
If Not IsError(m) Then
'if Match() found a hit then m will be the row number on sheet2
c.Offset(0, 2).Value = wsOut.Cells(m, "B").Value
End If
Next c
End Sub

Copy range to next available cell in different Worksheet

I'm working with an excel sheet that converts addresses from one format to another, pastes it in a sheet, and is then supposed to paste the correctly formatted addresses into the next available row in a master sheet of addresses that has thousands of records.
There could be hundreds of addresses that need to be pasted to the master sheet, so I'm trying to avoid limiting my rows and ranges by specific references for example a range like ("A2:A6790") would not work because the lists can get long in both the conversion sheet and the master sheet.
In the example below I use just one address but I need the code to be able to copy paste all the rows that have data (but not the header):
I need the highlighted row to copy to here:
I had to black out some of the addresses for privacy reasons, but I highlighted the row count to show how many records there are.
Here's my code:
`
Private Sub Convert()
Dim sap As Worksheet: Set sap = Sheets("SAP")
Dim con As Worksheet: Set con = Sheets("CONVERSION")
Dim abrv As Worksheet: Set abrv = Sheets("ABRV")
Dim slip As Worksheet: Set slip = Sheets("SLIP")
Dim ads As Worksheet: Set ads = Sheets("ADS")
Dim adsrng As Range: Set adsrng = ads.Range("B:B")
Dim conads As Range: Set conads = con.Range("W:W")
Dim saprngQW As Range: Set saprngQW = sap.Range("q:w")
Dim conrngOU As Range: Set conrngOU = con.Range("o:u")
Dim saprngDO As Range: Set saprngBO = sap.Range("B:O")
Dim conrngBN As Range: Set conrngBN = con.Range("B:N")
Dim sapcity2 As Range: Set sapcity2 = sap.Range("o:o")
Dim concity2 As Range: Set concity2 = con.Range("x:x")
Dim sapunion As Range: Set sapunion = Union(saprngQW, saprngBO)
Dim FndList, x&
'Dim nextrow As Long
'nextrow = slip.Cells(Rows.Count, "A").End(xlUp).Row + 1
'Dim pasteslip As Range: Set pasteslip = slip.Range("A" & nextrow)
sap.Select
sapunion.Copy
con.Select
con.Range("a:a").PasteSpecial xlPasteValues
sap.Select
sapcity2.Copy
con.Select
concity2.PasteSpecial xlPasteValues
adsrng.Copy
con.Select
conads.PasteSpecial xlPasteValues
FndList = abrv.Cells(1, 1).CurrentRegion
For x = 1 To UBound(FndList)
con.Cells.Replace What:=FndList(x, 1), Replacement:=FndList(x, 2), LookAt:=xlWhole, MatchCase:=True
Next
con.Select
con.Range("a:x").Copy slip.Range("A:X" & Rows.Count).End(xlUp).Offset(1, 0)
's2.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes *this
was a different approach I was going to try if there's no way to
fix things*
'it comes from this code:
'Sub CopyUnique()
'Dim s1 As Worksheet, s2 As Worksheet
'Set s1 = Sheets("Main")
'Set s2 = Sheets("Count")
's1.Range("B:B").Copy s2.Range("a" & nextrow)
's2.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
'End Sub
End Sub
`
I commented out some of the code I tried using before (I kept getting paste area is out of range). The error I'm getting now is: Run-time error '1004': Method 'Range' of object'_Worksheet' failed, when it gets to this line con.Range("a:x").Copy slip.Range("A:X" & Rows.Count).End(xlUp).Offset(1, 0)
Any ideas what I can do? I feel like I'm so close but there's something obvious staring me in the face that I can't see.
Figured it out! Adapted some code I used for another project. Wasn't able to get
it to skip copies but it works!
Dim ldestlRow As Long, i As Long
Dim ins As Variant
Dim h As String, won As String
Dim wo As Range
ldestlRow = slip.Cells(Rows.Count, 1).End(xlUp).Row + 1
ins = con.UsedRange
For i = 2 To UBound(ins)
won = ins(i, 7)
Set wo = Range("W2:W" & ldestlRow).Find(what:=won)
If wo Is Nothing Then
ldestlRow = slip.Cells(Rows.Count, 1).End(xlUp).Row + 1
con.Range("A" & i).EntireRow.Copy slip.Range("A" & ldestlRow)
End If

Getting Error messages on ranges

I am getting error messages i that state that variable isn't defined. And VB is coloring this code red If LCase(wb.Range("Q" & i) = "y" Then .AutoFilter and I don't know why.
It's really important that only rows with a "y" in column Q in each range is pasted, and not everything else.
I had to change i to 2 To 500, and j = 2 To 20, but am worried that I might get columns that I don't want pasted into Sheet2(Materials_Estimate). I just want the range columns to be pasted.
The ranges include Sheet2 information as shown in the picture below (B=text, c=text, D=text, F=up to 3 numbers, G=a letter y, H=text, I=a calculation copied from Sheet 1 of the qty*cost)
Can anyone assist me?
[Code]
Option Explicit
Sub Estimating2()
Application.ScreenUpdating = False
'naming the workbook and worksheets and ranges
Dim ProjectBudgeting1 As Workbook
Dim Materials_Budget As Worksheet
Dim Materials_Estimate As Worksheet
Dim LowesFax As Worksheet
Dim HomeDepotFax As Worksheet
Dim SBath1 As Range
Dim SBath2 As Range
Dim SBed1 As Range
Dim SBed2 As Range
Dim SBed3 As Range
Dim SBed4 As Range
Dim SHall As Range
Dim SFP As Range
Dim SRP As Range
Dim SKit As Range
Dim SGar As Range
Dim BuyOA As Range
Dim SFlorida As Range
Dim TargetRange As Range
Dim ActiveWorksheet As Worksheet
'naming the worksheets and ranges in code
Set ProjectBudgeting1 = ActiveWorkbook
Set Materials_Budget = Worksheets("Materials_Budget")
Set Materials_Estimate = Worksheets("Materials_Estimate")
Set LowesFax = Worksheets("LowesFax")
Set HomeDepotFax = Worksheets("HomeDepotFax")
Set SBath1 = Range("Materials_Budget!Supplies_Bathroom1")
Set SBath2 = Range("Materials_Budget!Supplies_Bathroom2")
Set SBed1 = Range("Materials_Budget!Supplies_Bedroom1")
Set SBed2 = Range("Materials_Budget!Supplies_Bedroom2")
Set SBed3 = Range("Materials_Budget!Supplies_Bedroom3")
Set SBed4 = Range("Materials_Budget!Supplies_Bedroom4")
Set SHall = Range("Materials_Budget!Supplies_Hallway")
Set SFP = Range("Materials_Budget!Supplies_FrontPorch")
Set SRP = Range("Materials_Budget!Supplies_RearPorch")
Set SKit = Range("Materials_Budget!Supplies_Kitchen")
Set SGar = Range("Materials_Budget!Supplies_Garage")
Set SFlorida = Range("Materials_Budget!Supplies_Florida")
'Here I'm calling out the column q and looking for a "Y"
Set BuyOA = Range("Materials_Budget!Buy_OrderApproval")
'Here I'm naming the source of the information that gets copied into other sheets
Set ActiveWorksheet = Materials_Budget
'Here is the sheet where the source cells are pasted
Set TargetRange = Range("Materials_Estimate!EstimateTableArea1")
'Looking for the "Y" in column q for duplicating and printing corresponding rows (i) and columns (j)
For i = 12 To 520
Cells("Q", i) = "Row " & i & " Col " & j
For j = 2 To 20
If LCase(wb.Range("Q" & i) = "y" Then .AutoFilter
i = i + 1
Range("Q" & i).Select
i = i - 1
Next q
Next i
For j = 1 To 5
Cells(i, j) = "Row " & i & " Col " & j
End Sub
Application.ScreenUpdating = True
End With
End Sub
[Code/]
I see many errors.
A) You have not declared your objects. For example, you need to declare SBath1, SBath2 etc.. as Range
B) You have declared ProjectBudgeting1 as workbook but then you are using it as a worksheet object.
C) When setting range, fully qualify them
D) Your wb object is undeclared. I would strongly suggest that you use Option Explicit at the top of your code
E) You have an extra bracket ) in wb.Range("Q12:Q" & LastRow))
F) Avoid the use of .Select INTERESTING READ
G) Finally, I would highly recommend on forgetting one word in vba and that is using End to stop a code. Reason is quite simple. It's like Switching your Computer using the POWER OFF button. The End statement stops code execution abruptly. Also the Object references held (if any) by other programs are invalidated.
Here is a basic gist on how your code should look like
Sub Estimating2()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range, rng2 As Range
Set wb = ActiveWorkbook '~~> Or ThisWorkbook?
Set ws = wb.Sheets("Sheet1")
With ws
Set rng1 = .Range("Supplies_Bathroom1")
Set rng2 = .Range("Supplies_Bathroom2")
'
'~~> And so on
'
End With
End Sub

Resources