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
Related
'Find & Copy Column for Actual Curtailed
Dim ws As Worksheet
Set ws = Worksheets("Report")
Range("A2:AC2").Find(What:="Actual Curtailed").ActiveCell.Select
Range("S20") = Application.WorksheetFunction.Sum(ws.Range(Column(ActiveCell.Column))).Copy
This code brings a compile error, I am presuming that I am doing some wrong by summing the column with where the active cell is.
I am trying to fine "actual curtailed", get the column number, and put the summation of that column in row S20.
Thanks
This code will do what you intend.
Dim SumClm As Variant
Dim SumRng As Range
With Worksheets("Report")
SumClm = Application.Match("Actual Curtailed", .Rows(2), 0)
If Not IsError(SumClm) Then
' from row 3 to the end of the column
Set SumRng = .Range(.Cells(3, SumClm), .Cells(.Rows.Count, SumClm).End(xlUp))
.Cells(20, "S").Value = WorksheetFunction.Sum(SumRng)
End If
End With
If the column isn't found S20 will remain blank.
I just did few edits to your code
Dim ws As Worksheet
Set ws = Worksheets("Report")
Range("A2:AC2").Find(What:="Actual Curtailed").Activate
Range("S20") = WorksheetFunction.Sum(Columns(ActiveCell.Column))
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
I have a large sheet of data:
Updated Data
where i need to copy only a speacific part of this data to another worksheet:
The data i need to copy is always 4 cells wide however can be at any row and column. The first column cell at the top will allways be the same text value and i need to copy then from that found cell, 4 cells across to the right and then down to the cells are empty. All subsequent ranges after the first will use the same columns have several empty cells bother above and below each range needed. The macro will be run using a "button" so doesn't need to be checking the value of the cell all the time. The images are simplified versions of the data but are very accurate. 0 is used to show data surrounding range, HELLO is the data inside the range and INT_EXT_DOOR is my searched for cell value which can be in any column between data sets but will be the same inside each data set. The first range always starts at row 2.
Each range has to be numbered, defined by another worksheets cell value. For example, if my cell value is 1 i need it to copy range 1, if my value is 2 copy range 2 ect.
I have been trying to no luck to get anything that works like needed and would appreciate any help, thanks.
Test the next function, please:
Private Function testReturnBlock(strBlock As String, blkNo As Long)
Dim sh As Worksheet, ws As Worksheet, lastRow As Long, searchC As Range
Dim rng As Range
Set sh = ActiveSheet ' use here your sheet to be processed
Set ws = Worksheets("Return") 'use here your sheet where the data will be returned
Set searchC = sh.UsedRange.Find(strBlock)
If searchC Is Nothing Then MsgBox "No such a field in the worksheet...": Exit Function
lastRow = sh.Cells(Rows.Count, searchC.Column).End(xlUp).row
'The following part works well only if the blocks are separated by empty rows, as you said it is your sheet data case...
Set rng = sh.Range(searchC, sh.Cells(LastRow, searchC.Column)).SpecialCells(xlCellTypeConstants)
ws.Range("A1").Resize(rng.Areas(blkNo).Rows.Count, 4).Value = rng.Areas(blkNo).Resize(, 4).Value
End Function
The above function should be called like this:
Sub testRetBlock()
testReturnBlock "INT_EXT_DOOR", 2
End Sub
But in order to see that the correct range has been returned, you must adapt them in a way (in your test sheet), do differentiate. I mean the second one to contain "HELLO1" (at least on its first row), the following "HELLO2" and so on...
Try this routine if it does what you need. otherwise it should be a good start for adding whatever you need on top.
Option Explicit
Sub CopyBlock()
Dim wb As Excel.Workbook
Dim wsSource As Excel.Worksheet
Dim wsDest As Excel.Worksheet
Dim wsSelect As Excel.Worksheet
Dim lBlockNo As Long
Dim strCellID As String
Dim lBlock As Long
Dim lRow As Long
Dim lBlockRow As Long
Dim lBlockCol As Long
Dim searchRange As Excel.Range
Dim bRange As Excel.Range
Dim cRange As Excel.Range
Set wb = ActiveWorkbook
' set the worksheet objects
Set wsSource = wb.Sheets("Source")
Set wsDest = wb.Sheets("Dest")
Set wsSelect = wb.Sheets("Select") ' here you select which block you want to copy
' Identifier String
strCellID = "INT_EXT_DOOR"
' Which block to show. We assume that the number is in cell A1, but could be anywhere else
lBlockNo = wsSelect.Range("A1")
lRow = 1
' Find block with lBlockNo
For lBlock = 1 To lBlockNo
' Search the identifier string in current row
Do
lRow = lRow + 1
Set searchRange = wsSource.Rows(lRow)
Set bRange = searchRange.Find(strCellID, LookIn:=xlValues)
Loop While (bRange Is Nothing)
Next lBlock
lBlockRow = bRange.Row
lBlockCol = bRange.Column
' Search the first with empty cell
Do
lRow = lRow + 1
Loop While wsSource.Cells(lRow, lBlockCol) <> ""
' Copy the range found into the destination sheet
Range(Cells(lBlockRow, lBlockCol), Cells(lRow - 1, lBlockCol + 3)).Copy wsDest.Range("A1")
' Note the block copied
wsDest.Cells(1, 6) = "Block No:"
wsDest.Cells(1, 8) = lBlockNo
' Clean up (not absolutely necessary, but good practice)
Set searchRange = Nothing
Set bRange = Nothing
Set cRange = Nothing
Set wsSource = Nothing
Set wsDest = Nothing
Set wsSelect = Nothing
Set wb = Nothing
End Sub
Let me know if you need more help
I am building a module to import text into an Excel workbook. After it imports, I want to format the data as a table. The problem I have is that the import will never have the same range.
I'm using the following code, but it throws an error, Run-time error '424': Object required.
Sub ImportRange()
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim rng As Range
Set ws = ThisWorkbook.Worksheets("Import")
lRow = ws.UsedRange.Row - 1 + ws.UsedRange.Rows.Count
lCol = ws.UsedRange.Column - 1 + ws.UsedRange.Columns.Count
Set rng = ws.Cells(lRow, lCol).Address(True, True)
'MsgBox Cells(lRow, lCol).Address(True, True)
End Sub
I've done quite a bit of searching, but I have been unable to find an answer or figure out how I should be doing this.
The end result would look something like this in the code with the start of the range always being set to $A$1:
ws.ListObjects.Add(xlSrcRange, Range("$A$1:$AM$90"), , xlYes).Name = _
"Import"
If your goal is to set a range to the used range on a sheet, it can be done simpler:
Set rng = ws.UsedRange
Obviously, you need to make sure that the usedrange on that sheet properly represents your imported data.
To convert the range to a table:
Dim Import_Table As ListObject
Set Import_Table = ws.ListObjects.Add(SourceType:=xlSrcRange, Source:=rng, XlListObjectHasHeaders:=xlYes)
Import_Table.Name = "Import"
Note: the code is for Excel 2010. For later versions, replace XlListObjectHasHeaders with HasHeaders
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