How can i find the next empty row in a workbook where i want to paste some content i copied early in another workbook.
This is what i get now:
Sub Retânguloarredondado1_Click()
Dim InputFile As Workbook
Dim OutputFile As Workbook
Dim Inputpath As String
Dim Outputpath As String '
Dim TP As Worksheet
Dim copyRange As Range
Dim pasteRange As Range
Dim cel As Range
Dim test As Range
Dim MyAr() As Variant
Dim n As Long
Dim LastRow As Long
' Set path for Input & Output
fileInputpath = "C:\Users\Nuno Bonaparte\Desktop\"
Outputpath = "C:\Users\Nuno Bonaparte\Desktop\"
'## Open both workbooks first:
Set InputFile = ActiveWorkbook
Set OutputFile = Workbooks.Open(Outputpath & "file2.xlsm")
Set TP = OutputFile.Worksheets("Folha1")
Set copyRange = InputFile.Sheets("file2").Range("A1,B3,C5,D7,E9")
Set pasteRange = OutputFile.Sheets("Folha1").Range("A1")
'~~> Get the count of cells in that range
n = copyRange.Cells.Count
'~~> Resize the array to hold the data
ReDim MyAr(1 To n)
n = 1
'~~> Store the values from that range into
'~~> the array
For Each cel In copyRange.Cells
MyAr(n) = cel.Value
n = n + 1
Next cel
'Now, paste to OutputFile worksheet:
OutputFile.Sheets("Folha1").Activate
pasteRange.Cells(1, 1).Resize(1, UBound(MyAr)).Value = _
MyAr
'Close InputFile & OutputFile:
'InputFile.Close
OutputFile.Save
OutputFile.Close
End Sub
The code works fine, but i would like to find the next empty row and paste the new content
Thank You.
Try this:
With OutputFile.Sheets("Folha1").Range("A:A").Find(vbNullString, [A1])
.Resize(1, Ubound(MyAr)) = MyAr
End With
Above code looks for the first empty cell after A1 and apply resize and assign value in that cell.
Is this what you're trying? You can also check this out to give you more idea. HTH.
Related
I have a simple loop that should copy ranges form three sheets and stack them on top of each other in another sheet. I define the ranges of each of the three sheets via a cell that counts rows in the Control Sheet.
I do not get an error message, however only the range of the first sheets gets pasted. I troubleshooted already to see if the loop is running until end and indeed it does. I cannot wrap my head around why only the range from the first sheets gets pasted in the final sheet.
Sub Loop()
Dim ws_Sheet As Worksheet, ws As Worksheet
Dim lng_LastRow As Long, lng_LastColumn As Long, lng_LastRowSheet As Long
Dim rng_WorkRange As Range
Dim arrSht, i
Dim counter As Integer
arrSht = Array("a", "b", "c")
Set ws_Sheet = Worksheets("d")
ws_Sheet.Cells.ClearContents
counter = 1
For i = 0 To 2
Set ws = Worksheets(arrSht(i))
lng_LastRow = Worksheets("Control").Range("E" & counter).Value + 1
lng_LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
lng_LastRowSheet = ws_Sheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rng_WorkRange = ws.Range(ws.Cells(1, 1), ws.Cells(lng_LastRow, lng_LastColumn))
rng_WorkRange.Copy ws_Sheet.Range("A" & lng_LastRowSheet)
counter = counter + 1
Next i
End Sub
The issue is
lng_LastRowSheet = ws_Sheet.Cells(Rows.Count, 1).End(xlUp).Row
is the last used row (the last row that has data).
And then you use that to start pasting
rng_WorkRange.Copy ws_Sheet.Range("A" & lng_LastRowSheet)
so you overwrite the last row of data!
The next free row is lng_LastRowSheet + 1 so you should paste there:
rng_WorkRange.Copy ws_Sheet.Range("A" & (lng_LastRowSheet + 1))
You can also see that in the debug data:
a $A$1:$B$338 to A1
b $A$1:$B$91 to A338
c $A$1:$B$356 to A428
a goes from A1:B338 but you start pasting b in A338 so it overwrites the last row of a.
I gave it a test:
Created worksheet Control with data like
Then created worksheets a, b and c like
with data until row 500 so there is enough.
Then created an empty worksheet d for the output.
And used the following code. Note I have optimized it so it uses meaningful variable names, which is much easier to read, understand and debug.
Option Explicit
Public Sub CopyData()
Dim SheetNames() As Variant
SheetNames = Array("a", "b", "c")
Dim wsDestination As Worksheet
Set wsDestination = ThisWorkbook.Worksheets("d")
wsDestination.Cells.ClearContents
Dim i As Long
For i = 0 To 2
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Worksheets(SheetNames(i))
Dim SourceLastRow As Long
SourceLastRow = ThisWorkbook.Worksheets("Control").Range("E" & i + 1).Value + 1
Dim SourceLastColumn As Long
SourceLastColumn = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
Dim DestinationFreeRow As Long
DestinationFreeRow = wsDestination.Cells(wsDestination.Rows.Count, 1).End(xlUp).Row + 1 ' Last used row +1
Dim SourceRange As Range
Set SourceRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(SourceLastRow, SourceLastColumn))
SourceRange.Copy wsDestination.Range("A" & DestinationFreeRow)
Next i
End Sub
And I get a perfect output like:
Note that in the output I have hidden some rows so you can see eveything is there. This code perfectly does what it is supposed to.
Stack Ranges (Vertically) From Multiple Worksheets
Sub StackRanges()
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sWorksheetNames() As Variant: sWorksheetNames = VBA.Array("a", "b", "c")
' Lookup (Source Last Row)?
Dim lws As Worksheet: Set lws = wb.Worksheets("Control")
Dim llrCell As Range: Set llrCell = lws.Range("E1")
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("d")
dws.UsedRange.ClearContents
Dim dfCell As Range: Set dfCell = dws.Range("A1")
Dim sws As Worksheet
Dim srg As Range
Dim slRow As Long
Dim slColumn As Long
Dim i As Long
' Loop.
For i = 0 To UBound(sWorksheetNames)
Set sws = wb.Worksheets(sWorksheetNames(i))
slRow = llrCell.Value + 1
slColumn = sws.Cells(1, sws.Columns.Count).End(xlToLeft).Column
Set srg = sws.Range("A1", sws.Cells(slRow, slColumn))
srg.Copy dfCell
' If you only need to copy values (since you're using '.ClearContents'),
' instead, use the most efficient:
'dfCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value
Set llrCell = llrCell.Offset(1) ' next source last row lookup cell
Set dfCell = dfCell.Offset(srg.Rows.Count) ' next first dest. cell
Next i
End Sub
The counter and the lng_lastRow variable is too messy.
I repaleced some code as follow：
Sub newLoop()
Dim ws_Sheet As Worksheet, ws As Worksheet
Dim lng_LastRow As Long, lng_LastColumn As Long, lng_LastRowSheet As Long
Dim rng_WorkRange As Range, rng_lastRange As Range
Dim arrSht, i
Dim counter As Integer
arrSht = Array("a", "b", "c")
Set ws_Sheet = Worksheets("Control")
ws_Sheet.Cells.ClearContents
For i = 0 To 2
Set ws = Worksheets(arrSht(i))
Set rng_lastRange = ws_Sheet.Cells(Rows.Count, 1).End(xlUp)
lng_LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
lng_LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Set rng_WorkRange = ws.Range(ws.Cells(1, 1), ws.Cells(lng_LastRow, lng_LastColumn))
rng_WorkRange.Copy rng_lastRange.Offset(1, 0)
Next i
End Sub
I have this program to copy an entire row to another sheet within the same workbook depending on if the person's name (pulled from let's say Sheet 1) is found to be on another spreadsheet (sheet 2).
The department is then used (From sheet 1) to place the name that is found on sheet 2 on the department specific sheet.
It is only printing the first instance of the condition and nothing else on every department page.
Main:
Sub copy2Sheets()
Dim table As Worksheet: Set table = Worksheets("Table")
Dim N As Long
N = 117
Dim i As Long
Dim tempDep As String
Dim tempName As String
tempDep = table.Cells(1, "B").value
tempName = table.Cells(1, "A").value
copyPaste tempName, Worksheets(Trim(tempDep))
'Loop Case:
For i = 2 To N - 1
tempDep = table.Cells(i, "B").value
tempName = table.Cells(i, "A").value
copyPaste tempName, Worksheets(Trim(tempDep))
Next i
End Sub
PasteFunction:
Sub copyPaste(Name As String, place As Worksheet)
'Worksheet Variables
Dim wsSource As Worksheet
Dim targSource As Worksheet: Set targSource = place
'CurrentLast Row As Long
Dim iTargetRow As Long
'Which Cell was Found
Dim FoundCell As Range
Dim copyTo As Long: copyTo = targSource.Cells(Rows.count, "A").End(xlUp).Row
'Assign Variables
Set wsSource = Worksheets("Last Month's BBS SafeUnsafe by ")
Set FoundCell = check(Name)
If Not FoundCell Is Nothing Then
copyTo = copyTo + 1
wsSource.Cells(FoundCell.Row).EntireRow.Copy targSource.Range("A" & copyTo)
End If
End Sub
Check function:
Public Function check(Name As String) As Range
Dim Rng As Range
Dim ws As Worksheet: Set ws = Worksheets("Last Month's BBS SafeUnsafe by ")
If Trim(Name) <> "" Then
Set Rng = ws.Range("C:C").Find(Name)
If Not Rng Is Nothing Then
Set check = Rng
End If
End If
End Function
Example Excel Sheets:
"Sheet 1"
Sheet 2
In the images, only the first entry from sheet 2 is being copied into every sheet, rather than every entry being pasted into their respective sheets.
Splitting up your code like that makes it more difficult to follow - try only using one method:
Sub copy2Sheets()
Const N As Long = 116 'use const for fixed values
Dim wsTable As Worksheet, wsBBS As Worksheet, i As Long
Dim wsDest As Worksheet, f As Range, tempDep As String, tempName As String
Set wsTable = ThisWorkbook.Worksheets("Table")
Set wsBBS = ThisWorkbook.Worksheets("Last Month's BBS SafeUnsafe by ")
For i = 1 To N
tempDep = Trim(wsTable.Cells(i, "B").Value)
tempName = Trim(wsTable.Cells(i, "A").Value)
If Len(tempName) > 0 Then
Set wsDest = ThisWorkbook.Worksheets(tempDep)
Set f = wsBBS.Columns("C").Find(what:=tempName, lookat:=xlWhole)
If Not f Is Nothing Then
f.EntireRow.Copy wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
End If
Next i
End Sub
I'm currently working on a Macro that its currently filtering a table based on a value and then it copies the data under a column after the filters have been applied (got that to work). However, I can't figure out how to paste those values in the same table overwriting the data under the visible cells within a different column. Values highlighted in red (picture) are being copied, now I need to paste them over only in the cells highlighted yellow. Thank you!
Public Sub DxcDateUpdate()
Application.ScreenUpdating = False
Dim Mwb As Workbook
Dim ws As Worksheet
Set Mwb = ThisWorkbook
Set ws = Mwb.Worksheets("Commission")
Set ws2 = Mwb.Worksheets("test")
lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.Range("A1").AutoFilter Field:=31, Criteria1:="DXC/TPV.com Enrollment"
ws.Range("AG2:AG" & lr).SpecialCells(xlCellTypeVisible).Copy Destination:=ws.Range '''here is where idk what to do?'''
Application.ScreenUpdating = True
End Sub
You cannot paste a discontinuous range as discontinuous. You should iterate between each range cell and copy it using offset, or building the range to Paste using c.row. Please, try the next adapted code:
Sub DxcDateUpdate()
Dim Mwb As Workbook, ws As Worksheet, rngVis As Range, c As Range, LR As Long
Set Mwb = ThisWorkbook
Set ws = Mwb.Worksheets("Commission")
Set ws2 = Mwb.Worksheets("test")
LR = ws.cells(ws.rows.Count, 1).End(xlUp).row
ws.Range("A1").AutoFilter field:=31, Criteria1:="DXC/TPV.com Enrollment"
Set rngVis = ws.Range("AG2:AG" & LR).SpecialCells(xlCellTypeVisible)
For Each c In rngVis.cells
c.Offset(0, -28).value = c.value
Next
End Sub
In order to make the code faster, of course, you should use some optimization lines (ScreenUpdating = False, EnableEvents = False, Calculation = xlCalculationManual, followed after by True, True, xlCalculationAutomatic).
Copy 'Filtered' Values Using Arrays
The following will loop through the criteria column to find the criteria (string). When found, in the same row, the value from the source column will be copied to the destination column.
The columns' values are written to arrays to speed up the process (the loop).
Option Explicit
Sub DxcDateUpdate()
Const wsName As String = "Commission"
Const fRow As Long = 2
Const cCol As String = "AE" ' Criteria
Const sCol As String = "AG" ' Source
Const dCol As String = "E" ' Destination
Const Criteria As String = "DXC/TPV.com Enrollment"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
Dim lRow As Long: lRow = rg.Rows.Count
Dim cData As Variant: cData = rg.Columns(cCol).Value
Dim sData As Variant: sData = rg.Columns(sCol).Value
With rg.Columns(dCol)
Dim dData As Variant: dData = .Value
Dim r As Long
For r = fRow To lRow
If cData(r, 1) = Criteria Then
dData(r, 1) = sData(r, 1)
End If
Next r
.Value = dData
End With
End Sub
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
Is there a way to copy multiple selected cells from excel as shown below? It always copies the whole range from the first selected cell to the last cell, rather than copying the values from selected cells.
A VBA code will be useful.
The following will help, this will copy the specified ranges to the clipboard so you can paste them into Notepad:
Sub CopyToClipboard()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
ws.Range("B11:B12,B14,B18,B20,B22").Copy
'copy range to clipboard
End Sub
UPDATE:
A possible workaround for this would be to use a Temp worksheet and add the selected values into it and then copy that range into the Clipboard, a little long winded, but it would work:
Sub CopyToClipboard()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
Dim work As Worksheet
Dim arr() As Variant
i = 0
For Each work In ThisWorkbook.Worksheets
If work.Name = "Temp" Then
Application.DisplayAlerts = False
work.Delete
Application.DisplayAlerts = True
End If
Next
'if Temp worksheet exists then delete it
For Each c In Selection
i = i + 1
ReDim Preserve arr(1 To i)
arr(i) = c.Value
Next
'above add the values from selection to an array
Set ws2 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws2.Name = "Temp"
'add a temporary worksheet
For x = LBound(arr) To UBound(arr)
ws2.Cells(x, 1).Value = arr(x)
Next x
'copy values from array into temp worksheet
LastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
ws2.Range("A1:A" & LastRow).Copy
'copy continuous range from Temp worksheet
End Sub