I've googled this but couldn't find a clear answer.
I have a workbook that contains lots of sheets, each sheet contains purchase order info.
I want to copy the same cell range from each sheet and compile a long list of all of those ranges.
my codes is currently;
Sub WorksheetLoop()
Sheets("5040001253").Select
Range("A4:O23").Select
Selection.Copy
Sheets("PO_Combi").Select
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
ActiveSheet.Range("A" & lastRow + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
My question is: is there a simple command that allows to replace the sheet named 5040001253 with that will make this macro repeat on all sheets? If not, could someone tell me what to do to make it so?
Next code copies Range("A4:O23") from each sheet (except PO_Combi) to column A of sheet PO_Combi:
Sub WorksheetLoop()
Dim sh As Worksheet
Dim shCombi As Worksheet
Dim lastrow As Long
Set shCombi = ThisWorkbook.Worksheets("PO_Combi")
For Each sh In ThisWorkbook.Worksheets
With shCombi
If sh.Name <> .Name Then
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
sh.Range("A4:O23").Copy
.Range("A" & lastrow + 1).PasteSpecial xlPasteValues
End If
End With
Next
Application.CutCopyMode = False
End Sub
Related
I am very new to macro . Iam using this code for concatenating two column values into one column. This code today failed , for 10 first rows of the sheet , and it worked for the rest of the rows.Why happened like this , i havent changed anything at all !
Thanks.
Sub FixCrossSell()
Dim wb As Workbook
Dim lr As Long
Set wb = ThisWorkbook
wb.Worksheets("CrossSell").Activate
Cells(2, 1).Value = "=B2&E2"
lr = Cells(Rows.Count, 2).End(xlUp).Row
Range("A2").Select
Selection.Copy
Range("A3:A" & lr).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.Calculate
Range("A2:A" & lr).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Try this:
Sub FiXCrossSell()
Dim lr As Long
With Worksheets("CrossSell")
lr = .Cells(Rows.Count, 2).End(xlUp).Row
With .Range("A2:A" & lr)
.FormulaR1C1 = "=rc2&rc5"
.Value = .Value
End With
End With
End Sub
Probably just count the cells in column B, then place the Formula in Column A
Sub Button1_Click()
Dim LstRw As Long, Rng As Range, Sh As Worksheet
Set Sh = Sheets("CrossSell")
With Sh
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
Set Rng = .Range("A2:A" & LstRw)
Rng = "=B2&E2"
End With
End Sub
Ah.. I see someone else answered this while I was thinking about it.
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 need your help on something.. I have the 1004 error message (application or object non defined) when running the following code (I put only the critical parts) :
Sub overwrite_CDL()
Dim sht As Worksheet, LastRow As Long
Set sht = ThisWorkbook.Worksheets("JDE_Greece")
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
sht.Activate
Range("M1").AutoFilter Field:=13, Criteria1:="#N/A"
Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Mismatches").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'we want to create a summary sheet with the matches and the N/A:'
sht.Range("M1").AutoFilter Field:=13, Criteria1:="<>#N/A"
sht.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Worksheets.Add(After:=Worksheets("Instructions")).Name = "Summary DRP"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub
Separately, everything works fine (no error messages, good output) but gives me the error 1004 when running together. The sheet I want to add is no created ("Summary DRP") even if the filters are set correctly.
I think the issue is related to the Selection / Copy but I don't know exactly why (I guess something is not defined properly..).
Can someone help me ? Thanks in advance :)
A few things....
Your code is hard to read without indents (that won't cause an error though).
You set your last row on the currently active sheet, which may not be "JDE_Greece".
After finding the last row, then you activate JDE_Greece.
You copy the selection.
You change sheets.
You paste into whatever cells are selected on the Mismatches sheet (K36:Z36 on my sheet).
You try and select the filtered to <>#N/A cells, but you haven't reselected the sheet yet so it can't select the cells and throws a Select Method of Range class failed error.
The moral of this story.... don't use Select.
So your code with nothing removed, but updated with comments:
Sub overwrite_CDL()
Dim sht As Worksheet, LastRow As Long
Dim sht1 As Worksheet, sht2 As Worksheet '\\New variables
Set sht = ThisWorkbook.Worksheets("JDE_Greece")
Set sht1 = ThisWorkbook.Worksheets("Mismatches") '\\Added reference to Mismatches.
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row '\\Add sheet reference (not really necessary on Rows.Count as row counts should be the same across sheets).
'sht.Activate '\\Don't need to Activate or Select.
sht.Range("M1").AutoFilter Field:=13, Criteria1:="#N/A" '\\Add sheet reference.
sht.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Copy '\\No need to Select, just copy.
'Selection.Copy '\\Don't need this as incorported into above line.
'Sheets("Mismatches").Select
sht1.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False '\\Added sheet and cell reference.
Application.CutCopyMode = False
'we want to create a summary sheet with the matches and the N/A:'
'\\Moved these two lines after the new sheet is created.
'\\sht.Range("M1").AutoFilter Field:=13, Criteria1:="<>#N/A"
'\\sht.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Select
'Selection.Copy '\\Don't need this as incorported into above line.
Set sht2 = ThisWorkbook.Worksheets.Add 'Add worksheet and use variable to reference it.
sht2.Name = "Summary DRP"
sht2.Move After:=ThisWorkbook.Worksheets("Instructions")
'Worksheets.Add(After:=Worksheets("Instructions")).Name = "Summary DRP" '\\This row is now the above 3 rows.
sht.Range("M1").AutoFilter Field:=13, Criteria1:="<>#N/A"
sht.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Copy '\\No need to Select, just copy.
sht2.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False '\\Added sheet and cell reference.
End Sub
And tidied up:
NB: I've removed the extra arguments you entered in the PasteSpecial - these are default values, so get set as that anyway.
Your code will still fail if 'Summary DRP' already exists.
Sub overwrite_CDL()
Dim sht As Worksheet, LastRow As Long
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht = ThisWorkbook.Worksheets("JDE_Greece")
Set sht1 = ThisWorkbook.Worksheets("Mismatches")
With sht
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("M1").AutoFilter Field:=13, Criteria1:="#N/A"
.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Copy
End With
sht1.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Set sht2 = ThisWorkbook.Worksheets.Add
With sht2
.Name = "Summary DRP"
.Move After:=ThisWorkbook.Worksheets("Instructions")
End With
With sht
.Range("M1").AutoFilter Field:=13, Criteria1:="<>#N/A"
.Range("A1:P" & LastRow).SpecialCells(xlCellTypeVisible).Copy
End With
sht2.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End Sub
I'm so close, but this isn't working quite yet.
What's wrong here?
Sub DUMMY_ITEMS()
'
' DUMMY_ITEMS Macro
Sheets("Operations").Select
Range("H2:V73").Select
Selection.Copy
Sheets("Raw Data").Select
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub '
I guess you mean you got an error trying to use the PasteSpecial line.
As a recommendation, try to avoid using Select, Selection, and ActiveSheet, instead use fully qualified Worksheets and Ranges.
"Reduced" Code
Sub DUMMY_ITEMS()
'
' DUMMY_ITEMS Macro
Dim LastRow As Long
Sheets("Operations").Range("H2:V73").Copy
With Sheets("Raw Data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & LastRow + 1).PasteSpecial xlPasteValues
End With
End Sub
I have a spreadsheet for entering a new set of data on a new row each day each day, the row contains formulas and formatting. I want to be able to click a button and it adds a row under the last row with entered data and copy the formulas and formatting only, ready for new data to be entered.
Below is my code:
Sub Button1_Click()
Dim ws As Worksheet
Dim varUserInput As Variant
Set ws = ThisWorkbook.Sheets("Summary")
With ws
varUserInput = .Range("D" & .Rows.Count).End(xlUp).Row
.Rows(varUserInput).Insert Shift:=xlDown
.Rows(1).Copy .Rows(varUserInput)
.Rows(varUserInput - 1).Copy
.Rows(varUserInput + 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
End Sub
The issue is that it will only copy the formula from the same hidden row each time.
Is this what you are trying (UNTESTED)?
Sub Button1_Click()
Dim ws As Worksheet
Dim varUserInput As Variant
varUserInput = InputBox("Enter Row Number where you want to add a row:", "What Row?")
If varUserInput = "" Then Exit Sub
Set ws = ThisWorkbook.Sheets("Sheet1") '<~~ Change as applicable
With ws
.Rows(varUserInput).Insert Shift:=xlDown
.Rows(1).Copy .Rows(varUserInput)
.Rows(varUserInput - 1).Copy
.Rows(varUserInput).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
End Sub