I am basically stuck. I have a code which allows me to browse a file, once the file is selected it copies all the data in that file and then allows me to select a worksheet, from any workbook that is open at that time. Once the worksheet is selected [this is where i get stuck] i want it to paste it into j7. instead it doesn't do that, baring in mind i will be changing the file name everyday as it has the current days date on it.
here is my code:
Sub Macro4()
'
' Macro4 Macro
'
'
Range("A1").Select
Dim fileStr As String
fileStr = Application.GetOpenFilename()
If fileStr = "False" Then Exit Sub
Workbooks.Open fileStr
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Window.Sheets(Array("Forecast_workings")).Select{**this is where i want to be able to select a worksheet from any open workbook and it will paste the data in cell J7 of that worksheet.**
Range("J7").Select
Application.CutCopyMode = False
Range("C16:C27").Select
Selection.Copy
Range("E16").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("G16:G27").Select
Selection.Copy
Range("C16").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("O16").Select
End Sub
I can see lot of errors in your code.
First things first. You avoid the use of .Select. INTERESTING READ
If I understand you correctly then to get the name of the sheet which user selects at runtime, you can use Application.InputBox with Type:=8. This will return a range and from that you can use .Parent.Name to get the name of the worksheet.
Is this what you are trying?
Your code can be written as (UNTESTED)
Sub Macro4()
Dim fileStr As String
Dim wb As Workbook, thiswb As Workbook
Dim ws As Worksheet, thisws As Worksheet
Dim Lcol As Long, LRow As Long
Dim Ret As Range
'~~> Set an object for thisworkbook and worksheet
Set thiswb = ThisWorkbook
'~~> Change this to the sheet from where you want to copy
Set thisws = thiswb.Sheets("Sheet1")
'~~> Let user choose a file
fileStr = Application.GetOpenFilename()
If fileStr = "False" Then Exit Sub
'~~> Set an object for workbook opened and it's worksheet
Set wb = Workbooks.Open(fileStr)
On Error Resume Next
Set Ret = Application.InputBox("Select a cell from the sheet you want to choose", Type:=8)
On Error GoTo 0
If Ret Is Nothing Then Exit Sub
Set ws = wb.Sheets(Ret.Parent.Name)
With thisws
'~~> Find Last column in row 2
Lcol = .Cells(2, .Columns.Count).End(xlToLeft).Column
'~~> Find last cell in Col 1
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Copy your range directly to new worksheet selected
.Range(.Cells(2, 1), .Cells(LRow, Lcol)).Copy ws.Range("J7")
.Range("C16:C27").Copy ws.Range("E16")
.Range("G16:G27").Copy ws.Range("C16")
Application.CutCopyMode = False
End With
End Sub
when working with multiple workbooks, dont use range() but wb.range(), where wb is defined with the set function.
Also activesheet can be tricky. Preferably name the sheet you are using sheets("whatever").
And for last, to copy things dont use activate/select, just do as this:
wb.sheets("whatever").range() thisworkbook.sheets("watever2").range("").
I also saw you dont use application.enableevents=false/true, so events will trigger like crazy and your activesheet (or cell) will change like crazy if you have code in worksheet_change section.
Related
I know already a few people had that problem but their solutions did not help me. I am pretty new to VBA and I want to copy a row if the respective first cell is not empty to another file and iterate as long as the data is.
So far so good. My code runs the first time and actually works (for one line). But then the macro does not open the file again and spits out an error. If I want to manually open the target file it says: "Removed Feature: Data Validation from /xl/worksheets/sheet2.xml part" (and I think this is the reason why it does not iterate further). Do you have any idea what I can do?
Sub transferData()
Dim LastRow As Long, i As Integer, erow As Long
LastRow = ActiveSheet.Range("BC" & Rows.Count).End(xlUp).Row
For i = 3 To LastRow
If IsEmpty(Cells(i, 63).Value) = False Then
Range(Cells(i, 55), Cells(i, 63)).Select
Selection.Copy
Workbooks.Open Filename:="PATH.xlsx"
Worksheets("NewProjects").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.PasteSpecial
ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.Save
ActiveWorkbook.Close SaveChanges:=False
Application.CutCopyMode = False
End If
Next i
End Sub
Data Validation for the file is corrupt (dropdown lists) - either delete Data Validation, or fix it
Once the file is fixed, the code bellow will copy the data without opening the destination file multiple times. It AutoFilters current sheet for empty values in column BK (63), and copies all visible rows, from columns BC to BK, to the end of the new file (starting at first unused cell in column A)
Option Explicit
Public Sub TransferData()
Const OLD_COL1 = "BC"
Const OLD_COL2 = "BK"
Const NEW_COL1 = "A"
Dim oldWb As Workbook, oldWs As Worksheet, oldLR As Long
Dim newWb As Workbook, newWs As Worksheet, newLR As Long
On Error Resume Next 'Expected errors: new file not found, new sheet name not found
Set oldWb = ThisWorkbook
Set oldWs = ActiveSheet 'Or: Set oldWs = oldWb.Worksheets("Sheet2")
oldLR = oldWs.Cells(oldWs.Rows.Count, OLD_COL1).End(xlUp).Row
Application.ScreenUpdating = False
Set newWb = Workbooks.Open(Filename:="PATH.xlsx")
Set newWs = newWb.Worksheets("NewProjects")
If Not newWs Is Nothing Then
newLR = newWs.Cells(oldWs.Rows.Count, NEW_COL1).End(xlUp).Row
With oldWs.Range(oldWs.Cells(2, OLD_COL2), oldWs.Cells(oldLR, OLD_COL2))
.AutoFilter Field:=1, Criteria1:="<>"
If .SpecialCells(xlCellTypeVisible).Cells.Count > 2 Then
oldWs.Range(oldWs.Cells(3, OLD_COL1), oldWs.Cells(oldLR, OLD_COL2)).Copy
newWs.Cells(newLR + 1, NEW_COL1).PasteSpecial
Application.CutCopyMode = False
newWs.Sort.SortFields.Clear
newWb.Close SaveChanges:=True
Else
newWb.Close SaveChanges:=False
End If
.AutoFilter
End With
End If
Application.ScreenUpdating = True
End Sub
So I would like my code to loop through sheets, depend on sheet name I would like to copy different range (if sheet will not be listed i want just to skip it) (lets say i know number/adress of the columns i would like to copy (number of rows might be different, depends on the orginal file i got) and i would like to copy all of these ranges one under another into sheet called check_data with additional column to the right saying from which sheet this part is comming from. I'm stuck sometimes this part of code works but it seems like it doesnt loop through the sheets.
So far i got this (but im totally new to vba)
Sub Copy_data()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set wb = ActiveWorkbook
Set ws1 = wb.Sheets("A")
Set ws2 = wb.Sheets("B")
Set ws3 = wb.Sheets("Check_data")
For Each ws In Worksheets
If ws.Name = "A" Then
ws1.Activate
ws1.Range("A1:Q1").Select
ws1.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ws3.Select
If ws3.Range("A1") = "" Then
ws3.Range("A1").Select
ActiveSheet.Paste
Else
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
End If
ElseIf ws.Name = "B" Then
ws2.Activate
ws2.Range("A1:Q1").Select
ws2.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ws3.Select
If ws3.Range("A1") = "" Then
ws3.Range("A1").Select
ActiveSheet.Paste
Else
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
End If
Else
End If
Next ws
End Sub
Thanks for any suggestions
A couple of things here. Always fully specify both the workbook and worksheets with objects, and preprend methods like Sheets with those objects, like this:
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set wb = ThisWorkbook
ws1 = wb.Sheets("A")
ws2 = wb.Sheets("Check_data")
ws1.Range("A1:Q1").Select
ws1.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
...and same thing when you are ready to paste, except that you need to explicitly activate the sheet that you are pasting into:
ws2.Activate
If ws2.Range("A1") = "" Then
ws2.Range("A1").Select
Selection.Paste
Else
Selection.End(xlDown).Offset(1, 0).Select
Selection.Paste
End If
Obviously, this isn't your entire code snippet rewritten, but it's the direction that you want to head in.
Sub CopyPaste()
'
' CopyPaste Macro
'
' Keyboard Shortcut: Ctrl+Shift+P
'
Range("A2:C5").Select
Selection.Copy
Sheets("A").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A6:C11").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("B").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A12:C17").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("C").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A18:C21").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("D").Select
Range("A2").Select
ActiveSheet.Paste
End Sub
I have trying making a Macro to do a basic task but I can't seem to figure it out, can anyone help please! I'm trying to create a macro that will copy data from one worksheet and place into another worksheet based on specific letter.
For example all "A" item will paste automatically into new worksheet name "A". This I can do with no problem. But, when I want to use the same macro with another row with different no of column is where I have my problem.
I already use recorded macro and then if the row from copy worksheet have been reduced, it will paste wrongly in new worksheet.
Is there any way to solve it?
thanks in advance.
P/S--> the new worksheet will have header in it. so it would be nice if they can paste start from A2 row. Can refer image below for example.
See Example / and see comment on the code
Option Explicit
Public Sub Example()
'Declare your Variables
Dim Sht As Worksheet
Dim rng As Range
Dim List As Collection
Dim varValue As Variant
Dim i As Long
With ThisWorkbook
'Set your Sheet name
Set Sht = ActiveWorkbook.Sheets("Sheet1")
'set your auto-filter, A1
With Sht.Range("A1")
.AutoFilter
End With
'Set your agent Column range # (1) that you want to filter it
Set rng = Range(Sht.AutoFilter.Range.Columns(1).Address)
'Create a new Collection Object
Set List = New Collection
'Fill Collection with Unique Values
On Error Resume Next
For i = 2 To rng.Rows.Count
List.Add rng.Cells(i, 1), CStr(rng.Cells(i, 1))
Next i
'Start looping in through the collection Values
For Each varValue In List
'Filter the Autofilter to macth the current Value
rng.AutoFilter Field:=1, Criteria1:=varValue
'Copy the AutoFiltered Range to new Workbook
Sht.AutoFilter.Range.Copy
Worksheets.Add.Paste
ActiveSheet.Name = Left(varValue, 30)
Next ' Loop back
'Go back to main Sheet and removed filters
Sht.AutoFilter.ShowAllData
Sht.Activate
End With
End Sub
Make sure to have header on your data, see below
i have this code:
Sub reportCreation()
Dim sourceFile As Variant
Dim wbSource As Workbook
Dim wbDest As Workbook
Dim sourceSheet As Worksheet
Dim destSheet As Worksheet
Dim rng As Range
Dim i As Long
Dim NValues As Long
If sourceFile = False Then
MsgBox ("Select the MyStats file that you want to import to this report")
sourceFile = Application.GetOpenFilename
Set wbSource = Workbooks.Open(sourceFile)
Set sourceSheet = wbSource.Sheets("Test Dummy Sheet")
Set rng = sourceSheet.Range("A:N")
rng.Copy
Set wbDest = ThisWorkbook
Set destSheet = wbDest.Sheets("MyStats")
destSheet.Range("A1").PasteSpecial
Application.CutCopyMode = False
wbSource.Close
End If
NValues = destSheet.Cells(destSheet.Rows.Count, 2).End(xlUp).Row
With destSheet
For i = 6 To NValues
' Cells(i, 3).NumberFormat = "0"
With Cells(i, 3)
.Value = Cells.Value / 1000000
.NumberFormat = "0.00"
End With
Next i
End With
End Sub
the code runs fine for the IF Statement part which is a simple cop and paste sort of scenario but then once the WS has been copied to the new WB i need column 3 to devide any cell in that is larger than 1M by 1M and as soon as the code finds the first cell with a value of over 1M i get an error message "Runtime Error 7, system out of memory" but i still have 2GB left of memory so this does not seem to be your tipycal out of mem issue where i need to close a few applications and it will run because it just does not.
i am wondering if there is an issue with my code?
some of the sample values that the code will look are:
16000000
220000
2048000
230000
16000000
230000
16000000
you may want to adopt a different approach like follows (see comments)
Option Explicit
Sub reportCreation()
Dim sourceFile As Variant
Dim sourceSheet As Worksheet
Dim tempCell As Range
sourceFile = Application.GetOpenFilename(Title:="Select the MyStats file that you want to import to this report", _
FileFilter:="Excel Files *.xls* (*.xls*),") '<-- force user to select only excel format files
If sourceFile = False Then Exit Sub '<-- exit if no file selected
Set sourceSheet = TryGetWorkSheet(CStr(sourceFile), "Test Dummy Sheet") '<-- try and get the wanted worksheet reference in the chosen workbook
If sourceSheet Is Nothing Then Exit Sub '<-- exit if selected file has no "Test Dummy Sheet" sheet
With sourceSheet '<-- reference your "source" worksheet
Intersect(.UsedRange, .Range("A:N")).Copy
End With
With ThisWorkbook.Sheets("MyStats") '<-- reference your "destination" worksheet
.Range("A1").PasteSpecial
Application.CutCopyMode = False
sourceSheet.Parent.Close
Set tempCell = .UsedRange.Cells(.UsedRange.Rows.Count + 1, .UsedRange.Columns.Count) '<-- get a "temporary" cell not in referenced worksheet usedrange
tempCell.Value = 1000000 'set its value to the wanted divider
tempCell.Copy ' get that value into clipboard
With .Range("C6:C" & .Cells(.Rows.Count, 2).End(xlUp).Row) '<-- reference cells in column "C" from row 6 down to last not empty one in column "B"
.PasteSpecial Paste:=xlValues, Operation:=xlPasteSpecialOperationDivide '<-- divide their values by clipboard content
.NumberFormat = "0.00" '<-- set their numberformat
End With
tempCell.ClearContents '<-- clear the temporary cell
End With
End Sub
Function TryGetWorkSheet(wbFullName As String, shtName As String) As Worksheet
On Error Resume Next
Set TryGetWorkSheet = Workbooks.Open(wbFullName).Sheets("Test Dummy Sheet")
End Function
I want to select and copy the first 3 rows and the last row in an Excel worksheet but in my code below the line Selection.Copy gives an error.
Sub SaveLastLine()
Dim WB As Workbook, filename As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("B1").Select
Selection.End(xlDown).Select
Union(Range("1:3"), Range(Selection, Selection.End(xlToRight))).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
End Sub
Please anyone can help me.
Working with selected ranges is probably your problem. Kellsens has given you a solution that works around this by first copying the first three rows, then copying the last row to the new worksheet.
If you want to do this all in one shot, you can first define the range, then copy the content of that range to the new workbook. Something like this:
Sub SaveLastLine()
Dim WB As Workbook
Dim myRange As Range
'copy the content
Set myRange = Union(Range(Range("B1:B3"), Range("B1:B3").End(xlToRight)), _
Range(Range("B1").End(xlDown), Range("B1").End(xlDown).End(xlToRight)))
myRange.Copy
'paste the content
Set WB = Workbooks.Add
WB.ActiveSheet.Range("A1").PasteSpecial
End Sub
When you create your new workbook, there's no activesheet to paste, that's the error cause. You could instantiate your new workbook to the declared variable Wb.
Considering that your data starts in "B1" and considering that your new worksheet will have 4 rows, I made some modifications to your code:
Sub SaveLastLine()
Dim wb As Workbook
Dim ws As Worksheet
Dim filename As String
Dim lastCol As Integer
Dim lastRow As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = ActiveSheet ' Here I instantiate the active worksheet
Set wb = Workbooks.Add ' Here I instantiate the new workbook
lastCol = ws.Range("B1").End(xlToRight).Column
lastRow = ws.Range("B1").End(xlDown).Row
ws.Range(ws.Cells(1, 2), ws.Cells(3, lastCol)).Copy wb.Worksheets(1).Range("B1") ' Here I copy the first 3 rows and paste in the first worksheet of your new workbook
ws.Range(ws.Cells(lastRow, 2), ws.Cells(lastRow, lastCol)).Copy wb.Worksheets(1).Range("B4") ' Here I copy the last row and paste
filename = "yourfilename.xlsx"
wb.SaveAs filename
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub