I'm trying to copy then paste into cells in a loop. Using cell BP3 as an original reference im trying to write it such that after each iteration it pastes into the next cell down from BP3 i.e BP4. But I currently just repeats in cell BP4.
' Copy and Paste of CAPEX 4 forecast dates from VR all DVs
Dim Updated_Spreadsheet As Workbook
Dim wb As Workbook: Set wb = Workbooks("study tracker.xlsm")
Set Updated_Spreadsheet = Workbooks("VR.xlsm")
Set sht = Updated_Spreadsheet.Sheets("Variance Report")
Set sht2 = wb.Sheets("Environmental Studies")
'Loop
Dim cell As Range, lRow As Long, NextRow As Long, lngDataRows As Long
For Each cell In sht2.Range("A3", sht2.Range("A" & Rows.Count).End(xlDown))
'specifying cell i want to use as a criteria for the filter
'cell = sht2.Range("A3").Value
sht.Activate
'specifying filter range
sht.Range("$A$7:$GV$4694").AutoFilter Field:=1, Criteria1:=cell
'specifying the exact cell from the filter which I would like to copy
sht.UsedRange.SpecialCells _
(xlCellTypeVisible).Areas(2).Columns(171).Cells(1, 1).Copy
wb.Activate
'pasting into new location
lngDataRows = cell.CurrentRegion.Rows.Count - 1
Range("BP3").Offset(lngDataRows + 1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next cell
You're only getting cell "BP4" because every time your loop runs you're selecting the same cell over and over again.
Initiate a variable (before starting your loop) that will increase in value with each loop iteration.
OffsetBy = 1
'Your "For Each" loop starts here
'(...)
'Use this variable in here:
Range("BP3").Offset(lngDataRows + OffsetBy, 0).Select
OffsetBy = OffsetBy + 1
Next cell
Hope this helps!
Related
I am not sure if I am performing this operation the most effectively, but I am attempting to copy products into newly created sheets if they are the same product.
For example if there are 4 products that are "Apples" and two that are "Oranges". Then I would like to create a new sheet for each product, rename the new sheet after said product, and place each row containing said product into each new sheet.
Currently, my program is running through a double loop. The first loop runs through each row in the first sheet, and the second loops through the sheet names.
The problem I am running into is with the first loop: the code creates a new sheet for the first product in the list, which is fine. But the next product in the list is the same product, so it should be placed into the newly-created sheet. However, my code creates another new sheet, attempts to rename it after the product next in the list, and then errors and says
"You can't name the sheet after a sheet named the same thing".
Now that is a Catch-22, because my if statement should catch it, but it doesn't.
I am running this is an outside workbook, after the program runs, I will save it under a different file name, so I'd prefer not to paste the date into the macro file and just keep it as a separate file.
CODE:
Dim fd As FileDialog
Dim tempWB As Workbook
Dim i As Integer
Dim rwCnt As Long
Dim rngSrt As Range
Dim shRwCnt As Long
Set fd = Application.FileDialog(msoFileDialogFilePicker)
For i = 1 To fd.SelectedItems.Count
Set tempWB = Workbooks.Open(fd.SelectedItems(i))
With tempWB.Worksheets(1)
For y = 3 To rwCnt
For Z = 1 To tempWB.Sheets.Count
If .Cells(y, 2).Value = tempWB.Sheets(Z).Name Then
.Rows(y).Copy
shRwCnt = tempWB.Worksheets(Z).Cells(Rows.Count, 1).End(xlUp).Row
tempWB.Worksheets(Sheets.Count).Range("A" & shRwCnt).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ElseIf tempWB.Sheets(Z).Name <> .Range("B" & y).Value Then
If Z = tempWB.Sheets.Count Then
.Range("A1:AQ2").Copy
tempWB.Worksheets.Add after:=tempWB.Worksheets(Sheets.Count)
tempWB.Worksheets(Sheets.Count).Name = .Cells(y, 2).Value
tempWB.Worksheets(Sheets.Count).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Rows(y).Copy
tempWB.Worksheets(Sheets.Count).Range("A3").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
End If
Next Z
Next y
End With
Next i
You need 1 loop to go through all rows of the sheet you want to scan. In this loop check if a sheet with the product name exists. If it exists find the next free row in it and past your data. If it does not exists add a sheet with that product name and paste in row 1.
Note that you can only use the left 31 characters of the product name for your worksheet names. Worksheet names have a limit.
Dim WsDest As Worksheet
For i = 1 To fd.SelectedItems.Count
Set tempWB = Workbooks.Open(fd.SelectedItems(i))
With tempWB.Worksheets(1)
For y = 3 To rwCnt
Set WsDest = Nothing
On Error Resume Next 'next line throws an error if the ws does not exist so hide errors
Set WsDest = Worksheets(Left$(.Cells(y, 2).Value, 31)) 'worksheet names are limited to 31 characters
On Error GoTo 0 're-activate error reporting
If WsDest Is Nothing Then 'if ws does not exist
'add this sheet name it and copy/paste
Set WsDest = Worksheets.Add
WsDest.Name = Left$(.Cells(y, 2).Value, 31) 'worksheet names are limited to 31 characters
.Rows(y).Copy
WsDest.Cells(1, 1).Paste
Else
'find last used row and copy/paste
shRwCnt = WsDest.Cells(WsDest.Rows.Count, 1).End(xlUp).Row
.Rows(y).Copy
WsDest.Cells(shRwCnt + 1, 1).Paste
End If
Next y
End With
Next i
Quick answer: Instead of looping through the existing sheets, you should see if the sheet you want exists, then just go there. Something like this:
For i = 1 To fd.SelectedItems.Count
If WorksheetExists(.Cells(y, 2).Value) Then'
'Copy the data into the existing sheet
end if
Next i
For the WorksheetExists function, see Test or check if sheet exists
As others have noted, you need to check all sheet names before you take action, but I recommend adding a function that stores the names of the worksheets into a dictionary to speed that process up. I did my best to update your code with this accordingly.
Function get_worksheet_names() As Object
Dim d As Object _
, sht As Worksheet
Set d = CreateObject("Scripting.Dictionary")
For Each sht In ThisWorkbook.Sheets
d.Add sht.Name, sht.Index
Next sht
Set get_worksheet_names = d
End Function
Sub update_workbook_sheets()
Dim fd As FileDialog
Dim tempWB As Workbook
Dim i As Integer
Dim sht_dict As Object
Dim tmpSht As Worksheet
Dim rwCnt As Long
Dim rngSrt As Range
Dim shRwCnt As Long
Set sht_dict = get_worksheet_names() 'get dictionary of sheets
Set fd = Application.FileDialog(msoFileDialogFilePicker)
For i = 1 To fd.SelectedItems.Count
Set tempWB = Workbooks.Open(fd.SelectedItems(i))
With tempWB.Worksheets(1)
For y = 3 To rwCnt
If sht_dict.Exists(.Cells(y, 2).Value) Then 'If sheet exists
.Rows(y).Copy
shRwCnt = tempWB.Worksheets(Z).Cells(Rows.Count, 1).End(xlUp).Row
tempWB.Worksheets(Sheets.Count).Range("A" & shRwCnt).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else 'if sheet does not exist
.Range("A1:AQ2").Copy
tempWB.Worksheets.Add after:=tempWB.Worksheets(Sheets.Count)
tempWB.Worksheets(Sheets.Count).Name = .Cells(y, 2).Value
tempWB.Worksheets(Sheets.Count).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Rows(y).Copy
tempWB.Worksheets(Sheets.Count).Range("A3").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Set sht_dict = get_worksheet_names()
End If
Next y
End With
Next i
End Sub
I'm trying to copy some rows from a sheet and then paste in other sheet that will contain the data. Later on I will erase the data form the original sheet to be fulfill again and repeat process.
My problem is that, it looks like I'm coping as well the empty cells from the original sheet so when paste for any reason excel consider this empty cell as the last one. More than sure I'm doing something wrong, the macro is this:
Sub CopyTable()
'
' CopyTable Macro
'
'
' Variables
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set sht = Worksheets("Form")
Set StartCell = Range("A9")
'Refresh UsedRange
Worksheets("Form").UsedRange
'Find Last Row and Column
LastRow = StartCell.SpecialCells(xlCellTypeLastCell).Row
LastColumn = StartCell.SpecialCells(xlCellTypeLastCell).Column
'Select Range
sht.Range(StartCell, sht.Cells(LastRow, LastColumn)).Select
' Copy range and move to Data sheet
Selection.Copy
Sheets("Data").Select
' Place pointer on cell A1 and search for next empty cell
Range("A1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
' Once find, go back once to place on last empty and paste data from Form sheet no formating
ActiveCell.Offset(0, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
End Sub
I assume that the data from the form always has an entry in column A - that there are no entries where A is blank but other cells on the row are not blank:
Sub CopyTable()
Dim sourcesheet As Worksheet
Dim DestSheet As Worksheet
Dim Source As Range
Dim dest As Range
Dim Startcell As Range
Set sourcesheet = ThisWorkbook.Worksheets("Form")
Set Startcell = sourcesheet.Range("A9")
Set Source = sourcesheet.Range(Startcell, Startcell.SpecialCells(xlCellTypeLastCell))
Set DestSheet = ThisWorkbook.Worksheets("Data")
Set dest = DestSheet.Cells(DestSheet.Rows.Count, 1).End(xlUp).Offset(1, 0)
'set dest to next blank row
Source.Copy dest
Set dest = DestSheet.Range(dest, dest.SpecialCells(xlCellTypeLastCell))
dest.Sort key1:=dest.Cells(1, 1)
'sort to shift blanks to bottom
End Sub
finally surfing in stackoverflow I found a pice of code that do exactly want I need, so final macro looks like this:
Sub CopyTable()
Dim lastVal As Range, sht As Worksheet
Set sht = Sheets("Form")
Set lastVal = sht.Columns(2).Find("*", sht.Cells(1, 2), xlValues, _
xlPart, xlByColumns, xlPrevious)
Debug.Print lastVal.Address
sht.Range("A9", lastVal).Resize(, 26).Select 'select B:Ag
Selection.Copy
Sheets("Data").Select
Range("A1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(0, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
End Sub
I'm fairly new to VBA user-forms so hopefully it's an easy fix.
I am using this code to move my entries from one sheet to another within the same workbook,but its working with some errors.
*I want it work on a specific sheet but its working on the active sheet.
**I want that after moving entries it should auto clear the specific sheet ( and I don't know how to do that :( )
Here is my code:
Private Sub CommandButton8_Click() 'Move Button
For Each cell In ThisWorkbook.Sheets("Daily").Range("endRange")
If IsDate(cell) = True Then
myEndRow = cell.Row
End If
Next cell
ThisWorkbook.Worksheets("Daily").Range("A2:E10000" & myEndRow).Select
Selection.Copy
Sheets("Data").Select
'Range("A2660").Select
ThisWorkbook.Worksheets("Data").Range("a99999").End(xlUp).Select
ActiveCell(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
Here is the link for the file:
Link
In your daily sheet in the code associated with the button put the following.
Please note i am not sure of the purpose of your test to see if there is a date. If you can clarify this i can amend the code accordingly. You don't need a button in the data sheet as this is where you are copying to. Make sure this code only resides in the sheet associated with the button i.e. Daily and does not exist elsewhere in the workbook.
Private Sub CommandButton1_Click() 'Move Button
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim rangeToCopy As Range
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Daily")
Set wsTarget = wb.Worksheets("Data")
Dim NextRow As Long
NextRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1 'Find next free row in Data sheet
Set rangeToCopy = wsSource.Range("A1").CurrentRegion.Offset(1, 0) 'get current set of rows that have data excluding header in daily sheet
rangeToCopy.Copy wsTarget.Cells(NextRow, "A") 'copy the new data from daily across to the next free row in the data sheet
rangeToCopy.ClearContents 'clear the contents of the daily sheet under the header
End Sub
The following is my VBA code, for some reason the code will run but not actually paste in the range I need it to paste. Anybody have any ideas why it won't paste my values?
The programs goes to my selected cell that I'm looking for, but now the activecell becomes my range and I'm trying to paste the it there. Any information will help, it just doesn't want to paste the values in the range I selected.
Sub Macro1()
Dim Form1033 As Worksheet
Dim CleaningSchedule As Worksheet
Set Form1033 = Worksheets("Form1033andForm1034")
Set CleaningSchedule = Worksheets("CleaningSchedule")
Dim Day As Range
Set Day = Form1033.Range("$J$3")
With Form1033
Range("$G$5:$G$18").Select
Selection.Copy
End With
With CleaningSchedule
Dim i As Integer
For i = 6 To 37
If Cells(4, i).Value = Day.Value Then
Cells(5, i).Select
Range(ActiveCell, Cells(ActiveCell.Rows + 13, ActiveCell.Column)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End If
Next i
End With
Form1033.Select
Application.CutCopyMode = False
Range("$G$5:$G$18").ClearContents
MsgBox "Scoresheet Updated"
End Sub
I fixed the code here, but please read the link I provided in my comment, and you will not have these errors in the future.
I also commented the refactors I did to the code. Also, notice that I assigned the Cells and Ranges to the parent worksheet with .. (See #BruceWayne's link in his comment to your original question)
Sub Macro1()
Dim Form1033 As Worksheet
Dim CleaningSchedule As Worksheet
Set Form1033 = Worksheets("Form1033andForm1034")
Set CleaningSchedule = Worksheets("CleaningSchedule")
Dim Day As Range
Set Day = Form1033.Range("$J$3")
'copy the range directly
Form1033.Range("$G$5:$G$18").Copy
With CleaningSchedule
Dim i As Integer
For i = 6 To 37
If .Cells(4, i).Value = Day.Value Then
'paste directly to range and i also combined 13 rows plus row 5, since you are always using the same row
Range(.Cells(5,i), Cells(18,i)).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End If
Next i
End With
'clear contenst directly
Form1033.Range("$G$5:$G$18").ClearContents
MsgBox "Scoresheet Updated"
End Sub
Since you are using "With" statement, you need to add a "." in front of "cells" and "range" and any other references you make. For example:
With myWorksheet
.range("A1").copy
End with
So, the problem in this case is that you still remain on the same worksheet and clear the contents of the cells you had pasted.
I need to copy a range (Sheet2 B2:S2), paste it on the same sheet on the first free row after row 7, paste the same data to the first empty row on Sheet1 and then clear the contents of the original range (Sheet2 B2:S2) ready for the next entry.
I have tried to use other posts but I can't figure out what to do.
Here is the macro that does the easy bit
Sub Macro2()
'
' Macro2 Macro
'
'
Sheets("Sheet2").Select
Range("B2:S2").Select
Selection.Copy
Range("B7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet2").Select
Range("B2:S2").Select
Application.CutCopyMode = False
Selection.ClearContents
End Sub
It pastes over the last line. I need it to find the next free line when pasting.
You're so close! The issue is that you never increment the destination range object -- it's always set to Range("B7"). The following heavily-commented code should achieve what you're after:
Option Explicit
Public Sub MoveRowFrom2To1()
Dim shtSource As Worksheet, shtResult As Worksheet
Dim rngSource As Range, rngResult As Range
Dim lngLastRowOnSheet1 As Long, lngLastRowOnSheet2 As Long
'Set references up-front
Set shtSource = ThisWorkbook.Worksheets("Sheet2")
Set shtResult = ThisWorkbook.Worksheets("Sheet1")
'Identify the last occupied row on Sheet1 and Sheet2
lngLastRowOnSheet1 = LastRowNum(shtResult)
lngLastRowOnSheet2 = LastRowNum(shtSource)
'If the last occupied row is < 7, default to 6 so it writes to 7
If lngLastRowOnSheet2 < 7 Then
lngLastRowOnSheet2 = 6
End If
'Identify the Source data and Sheet2 Destination
Set rngSource = shtSource.Range("B2:S2")
Set rngResult = shtSource.Cells(lngLastRowOnSheet2 + 1, 2) '<~ column 2 is B
'Copy the Source data from Sheet2 to lower on Sheet2
rngSource.Copy
rngResult.PasteSpecial (xlPasteValues)
'Identify the Sheet1 Destination
Set rngResult = shtResult.Cells(lngLastRowOnSheet1 + 1, 2) '<~ column 2 is B
'Paste the Source data from Sheet2 onto Sheet1
rngResult.PasteSpecial (xlPasteValues)
'Clear the Source range in anticipation of a new entry
rngSource.ClearContents
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 0
Public Function LastRowNum(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
LastRowNum = Sheet.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Else
LastRowNum = 0
End If
End Function
Try this, have tidied up by removing your select statements:
Sub Macro2()
Dim SourceRange, TargetRange1, TargetRange2 As Range
Dim RowToPaste As Long
'set range of source data
Set SourceRange = Sheets("Sheet2").Range("B2:S2")
'cater for chance that less than 7 rows are populated - we want to paste from row 8 as a minimum
If (Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row + 1) < 8 Then
RowToPaste = 8
Else
'Add 1 to the value of the last populated row
RowToPaste = Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row + 1
End If
'Set the address of the target 1 range based on the last populated row in column B
Set TargetRange1 = Sheets("Sheet2").Range("B" & RowToPaste)
'Copy Source to target 1
SourceRange.Copy Destination:=TargetRange1
'Cater for Sheet 1 being totally empty and set target row to 1
If Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row = 1 And _
Len(Sheets("Sheet1").Range("A1")) = 0 Then
RowToPaste = 1
Else 'set target row to last populated row + 1
RowToPaste = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
End If
'Set the target 2 range based on the last empty row in column A
Set TargetRange2 = Sheets("Sheet1").Range("A" & RowToPaste)
'Paste the source to target 2
SourceRange.Copy Destination:=TargetRange2
'Clear the source data
SourceRange.ClearContents
End Sub