Copy data from several tabs to one tab - excel

I am trying to repurpose combine_data_from_all_sheets.vb to pull data from several tabs.
Starting at O7:T7.
The data starts in the same range for each tab.
Some tabs may not have data and can be skipped.
These tabs have formulas with double quotes instead.
If there is data there won't be any blank spaces.
If row 11 has data then so does 7, 8, 9 and 10
The areas that I'm having trouble with I wrote notes within the code, which is all of the text in full caps.
Option Explicit
Public Sub CombineDataFromAllSheets()
Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
'Notes: "Src" is short for "Source", "Dst" is short for "Destination"
'Set references up-front
Set wksDst = ThisWorkbook.Worksheets("AOD")
lngDstLastRow = LastOccupiedRowNum(wksDst) '<- defined below
lngLastCol = LastOccupiedColNum(wksDst) '<- defined below
'Set the initial destination range
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
'Loop through all sheets
For Each wksSrc In ThisWorkbook.Worksheets
'Skip template sheet
'WOULD LIKE TO ADD AN OR STATEMENT HERE, SOMETHING LIKE NAME <> "TEMPLATE" OR "LIST" THEN
If wksSrc.Name <> "Template" Then
'WOULD LIKE THIS TO SEARCH FOR LAST ROW WITH DATA THAT ISN'T DOUBLE QUOTES/A FORMULA WITH NO VISIBLE VALUES
'Identify the last occupied row on this sheet
lngSrcLastRow = LastOccupiedRowNum(wksSrc)
'Store the source data then copy it to the destination range
'WOULD LIKE TO ONLY COPY DATA IF THERE ARE VALUES IN CELLS, BUT MACRO IS PICKING UP CELLS WITH DOUBLE QUOTES
'WOULD LIKE FOR THE MACRO TO ONLY COPY IF DATA EXISTS IN RANGE "O7:T7", IF DATA EXISTS HERE, CONTINUE TO COPY ALL DATA BELOW UNTIL CELLS ARE EMPTY (SKIP CELLS WITH "" AS VALUES)
'WOULD LIKE TO COPY AND PASTE SPECIAL INSTEAD OF FORMULAS
With wksSrc
Set rngSrc = .Range("O7:T7")
rngSrc.Copy Destination:=rngDst
End With
'Redefine the destination range now that new data has been added
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
End If
Next wksSrc
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last row
'OUTPUT : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last column
'OUTPUT : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function

Copy Data From Multiple Worksheets
Option Explicit
Sub CombineDataWorksheets()
' Define constants.
' Source
Const sFirstRowAddress As String = "O7:T7"
' The following two constants are related!
Const sNameExceptionsList As String = "AOD,Template,List"
Const sNameExceptionsDelimiter As String = ","
' Destination
Const dName As String = "AOD"
Const dFirstColumn As String = "A"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Write the number of worksheet rows to a variable ('wsrCount').
Dim wsrCount As Long: wsrCount = dws.Rows.Count
' Using the destination worksheet with the source first row address,
' write the following three source properties to variables.
Dim cCount As Long ' Source/Destination Columns Count
Dim sfRow As Long ' Source First Row
Dim scrgAddress As String ' Source Columns Range Address
With dws.Range(sFirstRowAddress)
cCount = .Columns.Count
sfRow = .Row
scrgAddress = .Resize(wsrCount - sfRow + 1).Address
End With
' Reference the destination first row range.
Dim dfrrg As Range ' Destination First Row Range
' Attempt to reference the last destination worksheet's row,
' the row of the bottom-most NON-EMPTY cell.
' Note that the Find method with its LookIn argument's parameter
' set to 'xlFormulas' will fail if the worksheet is filtered.
' It will NOT fail if rows or columns are just hidden.
Dim dlCell As Range
Set dlCell = dws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If dlCell Is Nothing Then ' the destination worksheet is empty
Set dfrrg = dws.Cells(1, dFirstColumn).Resize(, cCount)
Else ' the destination worksheet is not empty
Set dfrrg = dws.Cells(dlCell.Row + 1, dFirstColumn).Resize(, cCount)
End If
' Write the names from the name exception list to a zero-based string array,
' the name exceptions array ('sNameExceptions').
Dim sNameExceptions() As String
sNameExceptions = Split(sNameExceptionsList, sNameExceptionsDelimiter)
' Declare additional variables to be used in the loop.
Dim sws As Worksheet ' Source Worksheet
Dim srg As Range ' Source Range
Dim slCell As Range ' Source Last Cell
Dim rCount As Long ' Source/Destination Rows Count
Dim drg As Range ' Destination Range
' Loop through the worksheets collection of the workbook...
For Each sws In wb.Worksheets
' Check if the source name was NOT found in the name exceptions array.
If IsError(Application.Match(sws.Name, sNameExceptions, 0)) Then
' Reference the source columns range, the range from the first
' source row range to the bottom-most worksheet row range.
With sws.Range(scrgAddress)
' Attempt to reference the source worksheet's last row,
' the row of the bottom-most NON-BLANK cell.
' Note that the Find method with its LookIn argument's
' parameter set to 'xlValues' will fail if the worksheet
' is filtered, and even if rows or columns are just hidden.
Set slCell = .Find("*", , xlValues, , xlByRows, xlPrevious)
' Check if a source non-blank cell was found.
If Not slCell Is Nothing Then ' non-blank cell found
' Calculate the number of source/destination rows.
rCount = slCell.Row - sfRow + 1
' Reference the source range.
Set srg = .Resize(rCount)
' Reference the destination range.
Set drg = dfrrg.Resize(rCount)
' Write the values from the source to the destination range.
drg.Value = srg.Value
' Reference the next destination first row range.
Set dfrrg = dfrrg.Offset(rCount)
'Else ' non-blank cell not found; do nothing
End If
End With
'Else ' worksheet name is in the name exceptions array; do nothing
End If
Next sws
' Inform.
MsgBox "Data combined.", vbInformation
End Sub

Okay,
Option Explicit
Sub Pull_All_To_AOD()
Dim wksSrc As Worksheet 'Source Sheet
Dim wksDst As Worksheet 'Destination Sheet
Dim rngSrc As Range 'Source Range
Dim rngDst As Range 'Destination Range
Dim RowCount As Long
Set wksDst = ThisWorkbook.Worksheets("AOD")
'Iterate Worksheets
For Each wksSrc In ThisWorkbook.Worksheets
'Skip Template, AOD, and empty sheets
If wksSrc.Name <> "Template" And _
wksSrc.Name <> "AOD" And _
Trim(Application.WorksheetFunction.Concat(wksSrc.Range("O7:T7"))) <> "" Then
'Find Data Size
RowCount = wksSrc.Range("O" & Rows.Count).End(xlUp).Row - 6
'Copy Data to AOD sheet, next empty row
wksDst.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(RowCount, 6).Value = _
wksSrc.Range("O7").Resize(RowCount, 6).Value
End If
Next wksSrc
End Sub
I think this is what you're looking for. Let me know if I'm missing anything.

Related

Copy and paste data from another excel file (each tab)

I am trying to copy columns f:g from each tab in a file (wb). Each tab has a different amount of rows so I also need to include a ctrl+shift+down when selecting the range. When pasting into my current file (ws) I also need to consider an offset because I am pasting 2 columns each time (next to each other).
I tried the following code but I keep getting a Run time error (object doesn't support this property), what am I missing?
For i = 1 To wb.Sheets.Count
wb.Range("f2:G2").End(xlDown).Select.Copy
start.Offset(i + 2, 2).PasteSpecial xlPasteValues
Next i
Copy Values From All Worksheets
Sub Test()
' Before your code...
Const sFirstRowAddress As String = "F2:G2"
' First part of your code...
Dim wb As Workbook ' Set wb = ?
Dim Start As Range ' Set Start = ?
' New code...
' Using the first source worksheet, calculate the total number of rows
' ('trCount') and the number of columns ('cCount').
Dim trCount As Long
Dim cCount As Long
With wb.Worksheets(1).Range(sFirstRowAddress)
trCount = .Worksheet.Rows.Count - .Row + 1
cCount = .Columns.Count
End With
' Reference the first destination row ('drrg').
Dim drrg As Range: Set drrg = Start.Cells(1).Resize(, cCount)
Dim sws As Worksheet
Dim srg As Range
Dim slCell As Range
Dim drg As Range
Dim rCount As Long
For Each sws In wb.Worksheets
' Turn off AutoFilter.
If sws.AutoFilterMode Then sws.AutoFilterMode = False
' Reference the first source row...
With sws.Range(sFirstRowAddress)
' Attempt to reference the last non-empty cell ('slCell').
Set slCell = .Resize(trCount) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If Not slCell Is Nothing Then ' a non-empty cell was found
rCount = slCell.Row - .Row + 1
Set srg = .Resize(rCount)
Set drg = drrg.Resize(rCount)
drg.Value = srg.Value ' copy values
Set drrg = drrg.Offset(rCount) ' next first destination row
'Else ' all source cells are empty; do nothing
End If
End With
Next sws
' The remainder of your code...
End Sub

Transfer data from master sheet using offset from reference cell

I am trying to transfer data from one master sheet to multiple template sheets based on cell name match with sheet name of the template sheets using a specific offset in the master sheet. However the referencing does not seem to work. In my case sheet named "Combine" is the master sheet. The offset value based on match cellname is 6 columns away from the matched cell. I am getting debugging error. Can anyone fix the problem?
Sub Button5_Click()
Dim wkSht As Worksheet, wsC As Worksheet, rngSearch As Range
Dim shNCell As Range
Set wsC = Sheets("Combine")
Set rngSearch = wsC.Range("A4:A800")
For Each wkSht In ThisWorkbook.Worksheets
'find the sheet name cell in rngSearch:
Set shNCell = rngSearch.Find(what:=wkSht.Name, LookIn:=xlValues, Lookat:=xlWhole,
MatchCase:=False)
'if found:
If Not shNCell Is Nothing Then
'copy the below built array in the necessary place
wkSht.Range("F12").Resize(19, 1).Value = wsC.Range(shNCell.Offset(0, 6)).Value
End If
Next wkSht
End Sub
Lookup Values (VBA)
Option Explicit
Sub Button5_Click()
Const ExceptionsList As String = "Combine" ' comma-saparated, no spaces!
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source column range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets("Combine")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
If slRow < 4 Then Exit Sub
Dim srg As Range
Set srg = sws.Range(sws.Cells(4, "A"), sws.Cells(slRow, "A"))
' Write the names from the list (string) to an array ('Exceptions').
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, ",")
Dim sCell As Range
Dim dws As Worksheet
For Each dws In wb.Worksheets
' Check if not in list.
If IsError(Application.Match(dws.Name, Exceptions, 0)) Then
' '.Cells(.Cells.Count)' ensures the search starts with
' the first cell (irrelevant in this case but good to know).
' Think: After the last cell comes the first cell.
' Using 'xlFormulas' will allow you to find even if the cell
' is in a hidden row or column. The 'formula' and the 'value'
' are the same since 'xlWhole' is used.
' 'False' is the default value of the `MatchCase` argument.
With srg
Set sCell = .Find(What:=dws.Name, After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole)
End With
If Not sCell Is Nothing Then
dws.Range("F12").Value = sCell.EntireRow.Columns("G").Value
'or
'dws.Range("F12").Value = sCell.Offset(, 6).Value
'Else ' no cell found; do nothing
End If
'Else ' is in the exceptions list; do nothing
End If
Next dws
End Sub

searching for data in a lot of sheets and copying entire row if data is found to a separate work sheet in VBA

Hi I'm relatively new to VBA and programing and im having an "overflow" issue with my code
I'm trying to to go through the first 31 work sheets search for the term "Power On" in column C and when it find a match copy the entire row and paste it into Sheet33 it was working at one point for just a single sheet but now i cant get it to work after modifying it for the first 31 sheets
any help would be greatly appreciated!
Sub test()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim ws1 As Worksheet
Dim I As Integer
LCopyToRow = 1
For I = 1 To 31
Set ws1 = ActiveSheet
LSearchRow = 1
While Len(Range("A" & CStr(LSearchRow)).Value) > 0
'If value in column C = "Power On", copy entire row to Sheet33
If Range("C" & CStr(LSearchRow)).Value = "Power On" Then
'Select row in ws1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet33 in next row
Sheets("Sheet33").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = LCopyToRow + 1
'Go back to ws1
Sheets(ws1).Select
End If
LSearchRow = LSearchRow + 1
Wend
Exit Sub
Next I
End Sub
'Overflow' error happens when your declared data variable of a certain datatype can no longer hold the SIZE of the value you are putting in it.
Based on your code, LSearchRow and LCopyToRow are declared as INTEGER which can hold up to 32767 (rows). to fix this declare it as LONG instead of INTEGER:
Dim LSearchRow As Long
Dim LCopyToRow As Long
Here's an update to my answer. I made an alternative version of your code:
Sub GetPowerOn()
Dim ws As Worksheet
Dim wsResult As Worksheet
Dim nrow As Long
Dim actvCell As Range
Dim actvLrow As Long
Set wsResult = ThisWorkbook.Worksheets("Sheet33")
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets '~Loop through the sheets of the workbook
If Not ws.Name = "Sheet33" Then '~As long as the sheet is not Sheet33, fire the search,copy,paste function below
actvLrow = ws.Range("A" & Rows.Count).End(xlUp).Row '~ Set the lastrow of the active sheet
For Each actvCell In ws.Range("C1:C" & actvLrow) '~ Loop through the cells of column C
If actvCell.Value = "Power On" Then '~Look for criteria
ws.Rows(actvCell.Row & ":" & actvCell.Row).Copy '~Copy the row that matches the criteria
nrow = wsResult.Range("A" & Rows.Count).End(xlUp).Offset(1).Row '~Get the lastrow empty row of the output sheet
wsResult.Range("A" & nrow).PasteSpecial xlPasteValuesAndNumberFormats '~Paste to the next empty row
Application.CutCopyMode = False
End If
Next actvCell
End If
Next ws
Application.ScreenUpdating = True
End Sub
' The reason you are getting the same sheet is you are setting WS1 to ActiveSheet
' 31 times in a row -- not getting the first 31 sheets.
' ActiveSheet is whatever sheet you last happened to have in focus. Unless you
' know you want that (almost never), you should not use it.
' You want to avoids things like copy / paste / select. These are slow.
' You also want to avoid processing things row by row.
' Here is an example that should do what you want.
Sub ThirtyOneFlavors()
Const PowerColNum = 3 ' if you are sure it will always be column 3
Dim WS1 As Worksheet, WS33 As Worksheet
Dim PowerColumn As Range, PowerCell As Range, FirstCell As Range, R As Long
Set WS33 = ThisWorkbook.Sheets("Sheet33") ' Maybe this could use a clever name
WS33.Cells.Delete ' only if you want this
' using ThisWorkbook avoids accidentally getting some other open workbook
For Each WS1 In ThisWorkbook.Sheets
' here, put the names of any sheets you don't want to process
If WS1.Name <> WS33.Name Then
Set PowerColumn = WS1.UsedRange.Columns(PowerColNum)
' I am assuming Power On is the whole column
Set PowerCell = PowerColumn.Find("Power On", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not PowerCell Is Nothing Then ' if you found something
' we need to keep track of the first one found,
' otherwise Excel will keep finding the same one repeatedly
Set FirstCell = PowerCell
End If
While Not PowerCell Is Nothing ' if you keep finding cells
R = R + 1 ' next row
'.Value will hold all of the values in a range (no need to paste)
WS33.Cells(R, 1).EntireRow.Value = PowerCell.EntireRow.Value
' get the next one
Set PowerCell = PowerColumn.Find("Power On", after:=PowerCell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If PowerCell.Address = FirstCell.Address Then
' if we found the first one again, kill the loop
Set PowerCell = Nothing
End If
Wend
End If
Next WS1
End Sub
'Consolidate' Data
Option Explicit
Sub ConsolidateData()
' Source
Const sfIndex As Long = 1
Const slIndex As Long = 31
Const sFirstCell As String = "C2"
Const sCriteria As String = "Power On"
' Destination
Const dIndex As Long = 33
Const dFirstCell As String = "A2" ' has to be column 'A' ('EntireRow')
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the initial destination cell.
Dim dws As Worksheet: Set dws = wb.Worksheets(dIndex)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCell)
Dim dCell As Range: Set dCell = RefLastCellInColumn(dfCell)
If dCell Is Nothing Then ' no data found
Set dCell = dfCell
Else ' data found
Set dCell = dCell.Offset(1)
End If
Dim sws As Worksheet
Dim srg As Range
Dim scrg As Range
Dim sCell As Range
Dim n As Long
Application.ScreenUpdating = False
' Process each source worksheet...
For n = sfIndex To slIndex
Set sws = wb.Worksheets(n)
Set scrg = RefColumn(sws.Range(sFirstCell))
' Test for data...
If Not scrg Is Nothing Then ' data in column found
' Process each cell in source column range...
For Each sCell In scrg.Cells
' Check current cell agains criteria. To ignore case,
' i.e. 'POWER ON = power on', 'vbTextCompare' is used.
If StrComp(CStr(sCell.Value), sCriteria, vbTextCompare) = 0 Then
' Combine current cell into current source range.
' The combining is restricted to per worksheet ('Union').
Set srg = RefCombinedRange(srg, sCell)
End If
Next sCell
' Test for matches...
If Not srg Is Nothing Then ' match found
' Copy. This will work only if all source cells contain values.
' If some of them contain formulas, the results may be mixed
' (some rows containing the formulas, some only values) due to
' the source range being non-contiguous.
' This is prevented by either not combining the cells or
' by using 'PasteSpecial'.
srg.EntireRow.Copy dCell
' Create a reference to the next destination cell.
Set dCell = dCell.Offset(srg.Cells.Count)
' Unreference source range (before processing next worksheet).
Set srg = Nothing
'Else ' no match found
End If
'Else ' no data in column found
End If
Next n
' Activate destination worksheet.
'If Not dws Is ActiveSheet Then dws.Activate
' Save workbook.
'wb.Save
Application.ScreenUpdating = True
MsgBox "Data consolidated.", vbInformation, "Consolidate Data"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the bottom-most non-empty cell
' in the one-column range from the first cell ('FirstCell')
' through the bottom-most cell of the worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefLastCellInColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set RefLastCellInColumn = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
ByVal CombinedRange As Range, _
ByVal AddRange As Range) _
As Range
If CombinedRange Is Nothing Then
Set RefCombinedRange = AddRange
Else
Set RefCombinedRange = Union(CombinedRange, AddRange)
End If
End Function
An alternative method using Find and `FindNext'
Option Explicit
Sub test()
Const MAX_SHT = 3
Const PASTE_SHT = 4
Const TERM = "Power On"
Const COL = "C"
Dim wb As Workbook, ws As Worksheet
Dim n As Integer, LastRow As Long, count As Long
Dim rngFound As Range, rngTarget As Range, sFirst As String
Set wb = ThisWorkbook
' check number of sheets
If wb.Sheets.count < MAX_SHT Then
MsgBox "Too few sheets", vbCritical
Exit Sub
End If
' copy destination
With wb.Sheets(PASTE_SHT)
LastRow = .Cells(Rows.count, COL).End(xlUp).Row
Set rngTarget = .Cells(LastRow + 1, "A")
End With
' first 31 sheets
For n = 1 To MAX_SHT
Set ws = wb.Sheets(n)
LastRow = ws.Cells(Rows.count, COL).End(xlUp).Row
With ws.Range("C1:C" & LastRow)
' search for term
Set rngFound = .Find(TERM, lookin:=xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
sFirst = rngFound.Address
Do
ws.Rows(rngFound.Row).EntireRow.Copy rngTarget
Set rngTarget = rngTarget.Offset(1)
Set rngFound = .FindNext(rngFound)
count = count + 1
Loop While rngFound.Address <> sFirst
End If
End With
Next
MsgBox count & " rows copied", vbInformation
End Sub
ok just try the following code
many fixes are made and speedUps
Sub test()
' in a x64 environement better forget Integers and go for Longs
Dim LSearchRow As Long
Dim LCopyToRow As Long
Dim ws1 As Worksheet
Dim I As Long
Dim vldRng As Range
Dim maxRw As Long
Dim maxClmn As Long
Dim rngDest As Range
'2 Lines to speed code Immensly. Don't use them while debugging
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LCopyToRow = 1
Set rngDest = ThisWorkbook.Sheets("Sheet33").Cells(1, 1)
'Set rngDest = ThisWorkbook.Sheets(33).Range("A1") 'Alternative 01
'Set rngDest = Sheets(33).Range("A1") 'Alternative 02
For I = 1 To 31
Set ws1 = ThisWorkbook.Sheets(I)
Set vldRng = ws1.UsedRange ' Get range used instead of searching entire Sheet
maxRw = vldRng.Rows.Count
maxClmn = vldRng.Columns.Count
For LSearchRow = 1 To maxRw
'If value in column C = "Power On", copy entire row to Sheet33
If vldRng.Cells(LSearchRow, 3).Value = "Power On" Then
'Select row in ws1 to copy
vldRng.Cells(LSearchRow, 1).Resize(1, maxClmn).Copy
'Paste row into Sheet33 in next row
rngDest.Offset(LCopyToRow - 1, 0).PasteSpecial xlPasteValues
LCopyToRow = LCopyToRow + 1
End If
Next LSearchRow
Next I
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Assistance with the (XLtoright) function. VBA

I want to paste a column selection (a2:a200) to the next available column to the right.
I am having trouble doing this.
Here I am copying the data from Tables and pasting it in the last available column to the right.
Sub CopyMonthData() Worksheets("Tables").Range("d2:d200").Copy _
Worksheets("SalesInvoicesMonth").Range("a" & Columns.Count).End(xlToLeft).Offset(1, 0) End Sub
How can I make this work?
You could use UsedRange instead.
Sub CopyMonthData()
Dim iLastCol as Integer
With Worksheets("SalesInvoicesMonth")
iLastCol = .UsedRange.Column + .UsedRange.Columns.Count - 1
Worksheets("Tables").Range("d2:d200").Copy .Cells(1,iLastCol + 1)
End With
End Sub
Declaring iLastCol helps you understand how to calculate the value but the variable is not required. You could replace it in the copy function by its actual value --> - 1 and + 1 cancel each other, so you get .Cells(1,.usedRange.Column + .UsedRange.Columns.Count) as destination range.
Copy to the Next Available Column
A Quick Fix (End)
I'm assuming that you want to copy the column range D2:D200 in the source worksheet (Tables) to the second row of the column after (next to) the last non-empty column of the destination worksheet (SalesInvoicesMonth) and that both worksheets reside in the workbook containing this code (ThisWorkbook). Also, I'm assuming that all columns in the destination worksheet have headers in the first row, which will be the row used to calculate the column number.
Sub CopyMonthDataSimple()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Tables")
Dim dws As Worksheet: Set dws = wb.Worksheets("SalesInvoicesMonth")
sws.Range("D2:D200").Copy _
dws.Cells(1, dws.Columns.Count).End(xlToLeft).Offset(1, 1)
End Sub
The first 1 in .Offset(1, 1) means the second row, while the second 1 means the column next to the column of the last (not hidden) header cell.
A More Flexible Solution (Find)
The following will copy the column range from the given cell (sFirst) to the bottom-most non-empty cell of the column of the source worksheet to the destination worksheet starting with the cell in the given row (dfrow) of the column after the last non-empty column.
Adjust (play with) the values in the constants section.
Sub CopyMonthData()
' Constants & Workbook
' Source
Const sName As String = "Tables"
Const sFirst As String = "D2"
' Destination
Const dName As String = "SalesInvoicesMonth"
Const dfRow As Long = 2
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Attempt to create a reference to the Source Column Range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
Dim sfOffset As Long: sfOffset = sfCell.Row - 1
Dim slCell As Range
' The bottom-most non-empty cell in the Source Column.
Set slCell = sfCell.Resize(sws.Rows.Count - sfOffset) _
.Find("*", , xlFormulas, , , xlPrevious)
If slCell Is Nothing Then
MsgBox "The range from the 'First Source Cell' to the bottom-most " _
& "cell of the 'Source Column' is empty.", _
vbCritical, "CopyMonthData"
Exit Sub
End If
' The following...
Dim srCount As Long: srCount = slCell.Row - sfOffset
Dim srg As Range: Set srg = sfCell.Resize(srCount)
' ... is another way of doing...
'Dim srg As Range: Set srg = sws.Range(sfCell, slCell)
' Attempt to create a reference
' to the Destination First Cell Range ('dfCell').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dlCell As Range
' The bottom-most non-empty cell in the last non-empty column.
Set dlCell = dws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious)
Dim dCol As Long
If dlCell Is Nothing Then ' The Destination Worksheet is empty.
dCol = 1
Else
If dlCell.Column = dws.Columns.Count Then
MsgBox "The 'Destination Last Column' is not empty.", _
vbCritical, "CopyMonthData"
Exit Sub
Else
dCol = dlCell.Column + 1
End If
End If
Dim dfCell As Range: Set dfCell = dws.Cells(dfRow, dCol)
' Copy
' Copy values, formats and formulas.
srg.Copy dfCell
' Or copy values (only) by assignment (more efficient (faster)).
'dfCell.Resize(srCount).Value = srg.Value
dfCell.EntireColumn.AutoFit
End Sub

How to copy one row of data at a time from one sheet and paste into another sheet

I want to copy one row of data at a time from one sheet and pasting into another sheet. I need to repeat this 100 times. I also need to modify a couple of column values after pasting them.
My data is not pasting into new sheet correctly.
'Get column numbers which need to be modified
PolicyReference = DataWS.Range("A1", DataWS.Range("IV1").End(xlToLeft)).Find("PolicyReference").Column
InsuredCode = DataWS.Range("A1", DataWS.Range("IV1").End(xlToLeft)).Find("InsuredCode").Column
InsuredDescription = DataWS.Range("A1", DataWS.Range("IV1").End(xlToLeft)).Find("InsuredDescription").Column
For j = 1 To 100
'Worksheets(DataWS).Range("A1:A100").Copy Worksheets(DestinationWS).Range("A1")
'1. Find last used row in the copy range based on data in column A
CopyLastRow = DataWS.Cells(DataWS.Rows.count, "A").End(xlUp).Row
'2. Find first blank row in the destination range based on data in column A
DestLastRow = DestinationWS.Cells(DestinationWS.Rows.count, "A").End(xlUp).Offset(1).Row
'3. Copy & Paste Data
DataWS.Rows(j).EntireRow.Copy DestinationWS.Range("A" & DestLastRow)
DataWS.Range("A1:A100").Copy
DestinationWS.Range("A" & Rows.count).End(xlUp).Offset(2).PasteSpecial Paste:=xlPasteValues
Next j
This code will copy all but the first row from DataWs to DestinationWs. If you want to be more selective in what you copy modifications must be made to the code in the loop, at the bottom.
Private Sub Study()
' 244
Dim DataWs As Worksheet
Dim DestinationWs As Worksheet
Dim PolicyReference As Long
Dim InsuredCode As Long
Dim InsuredDescription As Long
Dim Fnd As Range
Dim CopyLastRow As Long
Dim DestLastRow As Long
Dim R As Long ' loop counter: rows
Set DataWs = Worksheets("Sheet1")
Set DestinationWs = Worksheets("Sheet2")
With DestinationWs
DestLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Get column numbers which need to be modified
With DataWs
Set Fnd = .Rows(1).Find("PolicyReference") ' spaces between words are permissible
' make sure the column is found before using it in your further code
If Fnd Is Nothing Then Exit Sub
PolicyReference = Fnd.Column
Set Fnd = .Rows(1).Find("InsuredCode")
If Fnd Is Nothing Then Exit Sub ' perhaps give a message before exiting
InsuredCode = Fnd.Column
Set Fnd = .Rows(1).Find("InsuredDescription")
If Fnd Is Nothing Then Exit Sub ' perhaps give a message before exiting
InsuredDescription = Fnd.Column
CopyLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False ' speeds up execution
For R = 2 To CopyLastRow ' start in row 2
DestLastRow = DestLastRow + 1
.Rows(R).Copy DestinationWs.Cells(DestLastRow, "A")
Next R
Application.ScreenUpdating = True
End With
End Sub
Columns and Ranges
I am considering these as two problems. Revealing the connection between them might lead to a more suitable solution.
The first part (including the function) illustrates how you can write the column numbers to an array which can later be used to process the data in those columns.
The second part illustrates how to copy values most efficiently. The loop is ignored.
Option Explicit
Sub ColumnsAndRanges()
Const sName As String = "Sheet1"
Const shRow As Long = 1
Const sHeadersList As String _
= "PolicyReference,InsuredCode,InsuredDescription"
Const sFirst As String = "A1"
Const dName As String = "Sheet2"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
'Part 1: Column Numbers
Dim shrg As Range: Set shrg = sws.Rows(shRow)
' Use the function 'getColumnNumbers'.
Dim sColNums As Variant: sColNums = getColumnNumbers(shrg, sHeadersList)
If IsEmpty(sColNums) Then
MsgBox "Could not find all the headers."
Exit Sub
End If
' Column Numbers Example:
Dim n As Long
For n = 1 To UBound(sColNums)
Debug.Print n, sColNums(n)
Next n
'Part 2: Copy Range Values
' Create a reference to the Source Range.
Dim slCell As Range ' Source Last Cell
Set slCell = sws.Cells(sws.Rows.Count, "A").End(xlUp)
Dim srg As Range
' Note how a cell address (sFirst) or a cell range (slCell) can be used.
Set srg = sws.Range(sFirst, slCell).EntireRow
' Create a reference to the Destination Range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range ' Destination First Cell
' When 'EntireRow' is used, only "A" or 1 can be used.
Set dfCell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
Dim drg As Range: Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
' Copy by assignment (most efficient when only values are to be copied).
drg.Value = srg.Value
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the column numbers in a one-based array.
' Remarks: The column numbers refer to the columns of the given range,
' not necessarily to the columns of the worksheet.
' If any of the headers cannot be found, 'Empty' is returned.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getColumnNumbers( _
ByVal RowRange As Range, _
ByVal HeadersList As String, _
Optional ByVal Delimiter As String = ",") _
As Variant
If RowRange Is Nothing Then Exit Function
If Len(HeadersList) = 0 Then Exit Function
Dim Headers() As String: Headers = Split(HeadersList, Delimiter)
Dim ColNums As Variant
ColNums = Application.Match(Headers, RowRange.Rows(1), 0)
If Application.Count(ColNums) = UBound(Headers) + 1 Then
getColumnNumbers = ColNums
End If
End Function
The following one line of code using AdvancedFilter will paste data to the destination sheet.
Sub CopyDataToAnotherSheet()
DataWS.Range("A1").CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=DataWS.Range("A1", _
DataWS.Cells(1, DataWS.Columns.Count).End(xlToLeft)), _
CopyToRange:=DestinationWS.Range("A1")
End Sub

Resources