I have a problem with my code. It does the trick of copy/paste correctly. However, I think there is something tricky. When I try to update my dynamic table it displays a message that the WB I'm currently working in already has data and if I want to replace it. When I choose "Yes/No" it immediately displays another column in my table that says that 81 registers are not been used in UTILITY. When I do everything by hand there are no problems. So, I guess thereĀ“s something wrong with my macro.
Option Explicit
Sub DailyTrans_MDM()
Call CopyPaste
End Sub
Sub CopyPaste()
Dim vFile As Variant
Dim folderPath As String
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet
vFile = Dir(folderPath & "*.xl*")
Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = ActiveSheet
Do While vFile <> ""
Application.ScreenUpdating = False
vFile = Application.GetOpenFilename("Daily Reports (*.xl*)," & "*.xl*", 1, "Select Report", "Open File", False)
If TypeName(vFile) = "Boolean" Then
Exit Sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = wbCopyFrom.Worksheets("ReporteCifrasControl")
End If
'--------------------------------------------------------------------------------------
wsCopyFrom.Range("A2:M" & wsCopyFrom.Range("A" & Rows.Count).End(xlUp).row).Copy
wsCopyTo.Range("A" & wsCopyTo.Range("A" & Rows.Count).End(xlUp).row + 1).PasteSpecial xlPasteValuesAndNumberFormats
wbCopyFrom.Close SaveChanges:=False
Dim rngCopy As Range, rngPaste As Range
With ActiveSheet
Set rngCopy = .Range(.Range("A2"), Cells(2, Columns.Count).End(xlToLeft))
Set rngPaste = .Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp)).Resize(, rngCopy.Columns.Count)
End With
rngCopy.Copy
rngPaste.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Loop
End Sub
I believe you want to do this
Copy row 2 from Column A to Last Used Column (LC)
Paste this in the first Non-Used Row (LR) in Column A
Dim LC As Long
Dim LR As Long
With ActiveSheet
LC = .Cells(2, .Columns.Count).End(xlToLeft).Column
LR = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngCopy = .Range(.Cells(1, 2), .Cells(LC, 2))
Set rngPaste = .Range("A" & LR)
End With
rngCopy.Copy
rngPaste.PasteSpecial xlPasteFormats
You missed some objects to be qualified in your code. No point in using the With Block if you are not going to use the With Block
Just realized you have multiple copy/pastes in your code. If this is the wrong one, use the format here to modify the other one.
Related
I am cycling through all the Green Tabs in a workbook. When I come to a row of data where there is no value in Column G, I select that row, cut it, and open another workbook entitled "Unpaid AR." In that workbook, I find the first unused row, and Paste. Everything functions properly except for the Paste - nothing pastes, and I have tried several different techniques. Any ideas what could be going wrong?
Public Sub CutNPaste()
Dim ws As Worksheet
Dim ARRange As String
Dim ARFilePath As String
Dim ARcell As Range
Dim CopyRange As String
Dim i As Integer
Dim varRange As String
ARFilePath = "Unpaid AR.xlsx"
For Each ws In ThisWorkbook.Worksheets
ws.Activate
If ws.Tab.ColorIndex = 10 Then 'If Tab is Green, Then...
ReportRows = ActiveSheet.UsedRange.Rows.Count 'Get how many rows in the report
Let ARRange = "G" & "2" & ":" & "G" & ReportRows 'Range to Inspect for Blanks
i = 2
For Each ARcell In Range(ARRange)
Let CopyRange = "A" & i & ":" & "I" & i 'Set the copy range when blank is encountered
If ARcell.Value = "" Then
Range(CopyRange).Select
Selection.Cut
Workbooks.Open ARFilePath 'Open the Unpaid AR workbook
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select 'Find the first open row
ActiveSheet.Paste 'This is where NOTHING happens
Workbooks("Unpaid AR.xlsx").Close SaveChanges:=True 'Save and close destination wkbk
Application.CutCopyMode = False
End If
i = i + 1
Next ARcell
End If
Next ws
End Sub
i change a little bit...
Public Sub CutNPaste()
Dim ws As Worksheet
Dim ARRange As String
Dim ARFilePath As String
Dim ARcell As Range
Dim CopyRange As Range
Dim i As Integer
Dim varRange As String
Dim wkbTarget As Workbook
Dim ReportRows As Long
ARFilePath = ThisWorkbook.Path & "\Unpaid AR.xlsx"
Set wkbTarget = Workbooks.Open(ARFilePath) 'Open the Unpaid AR workbook
For Each ws In ThisWorkbook.Worksheets
If ws.Tab.ColorIndex = 10 Then
ReportRows = ws.UsedRange.Rows.Count
For i = ReportRows To 2 Step -1
Set CopyRange = ws.Range("A" & i & ":" & "I" & i)
If ws.Cells(i, 7).Value = "" Then
CopyRange.Cut Destination:=wkbTarget.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Application.CutCopyMode = False
End If
Next i
End If
Next ws
wkbTarget.Close SaveChanges:=True 'Save and close destination wkbk
End Sub
BR
Bernd
I am new to macro.
I have written macro code to add the rows based on filter from the macro enabled excel file and copy the results in new excel file.
I have VBS to run the macro.
My problem is
when I run the macro from the xlsm file ,it is running only once and the values are stored correctly by creating the xlsx file
But when I run the same macro from VBS, macro is running multiple times with error msg which is posted below
My Macro is :
Sub SuppOSCalculation()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim filterRange As Range
Dim lastRow As Long
Dim lastCol As Long
Dim Total As Double
Dim AddRange As Range
Dim c As Variant
Dim list As Object, item As Variant
Dim i As Integer
spath = "Mypath\"
sFile = spath & "supp.xlsm"
Set wb = Workbooks.Open(sFile)
SendKeys "{Enter}"
Set src = wb.Sheets("supp")
Set tgt = wb.Sheets("Sheet3")
Set list = CreateObject("System.Collections.ArrayList")
i = 2
' turn off any autofilters that are already set
src.AutoFilterMode = False
' Copy all fileds to second sheet and remove duplicates
src.Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row).Copy tgt.Range("A2")
tgt.Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
' Add all values in Second sheet to a list
With tgt
For Each item In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
If Not list.Contains(item.Value) Then list.Add item.Value
Next
End With
tgt.Range("A1").Value = "Supplier GL Code"
tgt.Range("B1").Value = "Supplier OS Report-Invoice Amount"
' find the last row and Column with data in column A
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
lastCol = src.Cells(1, Columns.Count).End(xlToLeft).Column
'MsgBox lastCol
' the range that we are auto-filtering (all columns)
Set filterRange = src.Range("A2:AF2" & lastRow)
For Each item In list
'From List set the value for the filter
' MsgBox (item)
filterRange.Range("C2").AutoFilter field:=3, Criteria1:=item
'Add the column value after applying filter
Set AddRange = src.Range("P3:P" & src.Range("P" & Rows.Count).End(xlUp).Row)
Total = WorksheetFunction.Sum(AddRange.SpecialCells(xlCellTypeVisible))
'MsgBox (Total)
tgt.Range("B" & i).Value = Total
i = i + 1
Next
'src.AutoFilterMode = False
'wb.Close SaveChanges:=True
Dim lRow, lCol As Integer
tgt.Select
lRow = Range("A" & Rows.Count).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
For Each cell In Range(Cells(1, "B"), Cells(1, lCol))
Union(Range("A2:A" & lRow), Range(Cells(2, cell.Column), Cells(lRow, cell.Column))).Copy
Workbooks.Add
Range("A1").PasteSpecial
ActiveWorkbook.SaveAs Filename:= _
"SupOSTBCalc\" & cell.Value & ".xlsx" 'You might want to change the extension (.xls) according to your excel version
Next cell
ActiveWorkbook.Close
Application.CutCopyMode = False
'wb.Close
' Application.DisplayAlerts = False
' Application.AlertBeforeOverwriting = False
' Application.ScreenUpdating = False
' SendKeys "{Enter}"
wb.Close savechanges:=False
End Sub
VBS is:
Dim xlApp
Dim xlBook
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("Mypath\SupOSTBCalc.xlsm")
xlApp.Run "Module1.SuppOSCalculation"
'xlBook.Save
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
Error msg is
Pls help me to solve this.
I have some tables from Excel that will be updated every month or so, what I am trying to do is to copy and paste those ranges from a "master workbook" to some several sheets. The way this works is I have 20 plus workbooks with those ranges "tables" already there, but I am having to manually open those workbooks then copy and paste the new values from the master workbook and close it.
Sub openwb()
Dim wkbk As Workbook
Dim NewFile As Variant
Dim ws As Worksheet
Dim rngCopy As Range, aCell As Range, bcell As Range
Dim strSearch As String
Dim StrFile As Variant
Dim wb2 As Excel.Workbook
Application.DisplayAlerts = True
Application.ScreenUpdating = True
StrFile = Dir("C:\temp\*.xlsx*")
Do While Len(StrFile) > 0
Set wb = Workbooks.Open(StrFile)
'NewFile = Application.GetOpenFilename("microsoft excel files (*.xl*), *.xl*")
'
'If NewFile <> False Then
'Set wkbk = Workbooks.Open(NewFile)
'''**********************
strSearch = "Descitption"
Set ws = Worksheets("TestCases")
With ws
Set aCell = .Columns(4).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bcell = aCell
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Do
Set aCell = .Columns(4).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bcell.Address Then Exit Do
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Else
Exit Do
End If
Loop
Else
MsgBox SearchString & " not Found"
End If
'~~> I am pasting to Output sheet. Change as applicable
Set wb2 = Workbooks.Open("C:\temp\Bulk tool\test1.xlsm")
If Not rngCopy Is Nothing Then rngCopy.Copy 'paste to another worksheet Sheets("Output").Rows(1)
End With
'**************************
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
StrFile = Dir
Loop
End Sub
The range is dynamic, it can change from 2 rows to 20, but to give an example A1:K20 and it will go to the same range to another workbook.
first off let me thank everyone helping me on this.
here is what I have so far (see code)
when I run it I am getting error 1004 not sure what I changed but it was working fine, also what I am trying to do, is to copy to another worksheet.
Copying and pasting values in a worksheet uses the Range.Copy and Range.PasteSpecial.
An example code is as follows:
Sub CopyThis()
Dim Sht1 As Worksheet, Sht2 As Worksheet
Set Sht1 = ThisWorkbook.Sheets(1)
Set Sht2 = ThisWorkbook.Sheets(2)
Sht1.Range("A1:D4").Copy
Sht2.Range("A1:D4").PasteSpecial xlPasteAll
End Sub
Alternatively, you can also loop through values. I usually do this out of preference because I often do "If Then" in loops
Sub CopyThis2()
Dim Sht1 As Worksheet, Sht2 As Worksheet
Set Sht1 = ThisWorkbook.Sheets(1)
Set Sht2 = ThisWorkbook.Sheets(2)
Dim i As Long, j As Long
For i = 1 To 4
For j = 1 To 4
Sht2.Cells(i, j).Value = Sht1.Cells(i, j).Value
Next j
Next i
End Sub
Perhaps you can do little tricks with coding to make it faster. Like in this Answer below
Looping through files in a Folder
You can Also use Application.Screenupdating = False before the loop & True after the loop, so that your process would be way faster. In the Loop you can put the Code suggested by Parker.R ....
Also, there is no other way to copy data from workbooks without opening them in VBA.All you can do it play with the way files are being opened and closed so that the process becomes faster.
Other than Screenupdating few more properties you can Set As per this Link
Code to loop Using FSO
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim objFSO As Object
Dim objFolder, sfol As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.getFolder(f_add) ''''f_add is the Address of the folder
'''' Loop For Files in That Folder
For Each objFile In objFolder.Files
''''Your Code
Next
'''' Loop for All the Subfolders in The Folder
For Each sfol In objFolder.subfolders
''' Your Code Here
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
I'm running into an issue with looping through tabs in my workbook. The code I am working on is supposed to perform the following:
Loop through all worksheets except the ones titled "BOAT" & "Data"
Select cell "A2" (A2 contains the value to filter)in each worksheet that it is looping through and use it as the autofilter value for the "Data" tab
Then copy and paste the filtered data into the respective tab that is looping through.
The issue I am running into is my code isn't picking up on the active sheet in the loop. Is there a way to create a variable to for the worksheet currently being looped through?
Code below. Thank you!
Sub updatedata()
Dim ws As Worksheet
Dim wsheet2 As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.name <> "BOAT" And ws.name <> "Data" Then
Call filter1
End If
Next ws
End Sub
Sub filter1()
Dim lastrow As Long
Dim lastrow2 As Long
Dim wSheet As Worksheet
Dim rInput As String
Application.DisplayAlerts = False
Set wSheet = ActiveSheet
rInput = wSheet.Range("A2").Value
Sheets("Data").Activate
lastrow = Range("A" & Rows.Count).End(xlUp).Row
ActiveSheet.Range("A1:Y" & lastrow).AutoFilter field:=4, Criteria1:="=*" & rInput & "*"
lastrow2 = Range("G" & Rows.Count).End(xlUp).Row
Range("G1:G" & lastrow2).Copy
wSheet.Activate
Range("A4").PasteSpecial xlPasteValues
Rows(4).EntireRow.Delete
Application.DisplayAlerts = True
End Sub
"Is there a way to create a variable to for the worksheet currently being looped through?"
Yes, using a Worksheet variable as an argument in filter1.
Avoid using Activate or making Range calls without specifying the Worksheet.
Sub updateData()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "BOAT" And ws.Name <> "Data" Then
filter1 ws 'no need to use Call
End If
Next ws
End Sub
By passing ws as an Argument to filter1, all Range calls are fully qualified with the Worksheet in question. This is easily accomplished with a With...End With block - note the period . in front of .Range("A2").Value, .Range("A4"), etc - equivalent to myWs.Range("A2").Value, myWs.Range("A4")..., etc.
Sub filter1(myWs As Worksheet)
Dim lastRow As Long, lastRow2 As Long
Dim rInput As String
Application.DisplayAlerts = False
With myWs
rInput = .Range("A2").Value
With .Parent.Sheets("Data")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:Y" & lastRow).AutoFilter field:=4, Criteria1:="=*" & rInput & "*"
lastRow2 = .Range("G" & .Rows.Count).End(xlUp).Row
.Range("G1:G" & lastRow2).Copy
End With
.Range("A4").PasteSpecial xlPasteValues
.Rows(4).EntireRow.Delete
End With
Application.DisplayAlerts = True
End Sub
i am attempting to write a script that goes over a specific column and then copies all rows containing the value of "rejected" in said column to a new excel file/workbook.
Everything seems to work just fine except for the actual Paste command which fails every time.
The code:
Sub button()
Dim x As String
Dim found As Boolean
strFileFullName = ThisWorkbook.FullName
strFileFullName = Replace(strFileFullName, ".xlsm", "")
strFileFullName = strFileFullName + "_rejected.xlsx"
' MsgBox strFileFullName
Set oExcel = CreateObject("Excel.Application")
Set obook = oExcel.Workbooks.Add(1)
Set oSheet = obook.Worksheets(1)
oSheet.Name = "Results"
' Select first line of data.
Range("E2").Select
' Set search variable value.
x = "rejected"
' Set Boolean variable "found" to false.
found = False
' Set Do loop to stop at empty cell.
Do Until IsEmpty(ActiveCell)
' Check active cell for search value.
If ActiveCell.Value = "" Then
Exit Do
End If
If ActiveCell.Value = x Then
found = True
rowToCopy = ActiveCell.Row
ActiveSheet.Rows(ActiveCell.Row).Select
Selection.Copy
oSheet.Range("A1").Select
lastrow = oSheet.Cells(Rows.Count, "B").End(xlUp).Row
' oSheet.Rows(1).Select.PasteSpcial
End If
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Loop
' Check for found.
If found = True Then
MsgBox "Value found in cell " & ActiveCell.Address
Else
MsgBox "Value not found"
End If
obook.SaveAs strFileFullName
obook.Close
End Sub
Any idea why i keep failing with the paste function?
Thanks!
Try this, no selects involved.
Sub AddWB()
Dim nwBk As Workbook, WB As Workbook, Swb As String
Dim Rws As Long, Rng As Range, c As Range, sh As Worksheet
Set WB = ThisWorkbook
Set sh = WB.Worksheets("Sheet1")
Rws = sh.Cells(Rows.Count, "E").End(xlUp).Row
Set Rng = Range(sh.Cells(2, 5), sh.Cells(Rws, 5))
Set nwBk = Workbooks.Add(1)
Swb = WB.Path & "\" & Mid(WB.Name, 1, Len(WB.Name) - 5) & ".xlsx"
MsgBox Swb
For Each c In Rng.Cells
If c = "x" Then c.EntireRow.Copy nwBk.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Next c
nwBk.SaveAs Filename:=Swb
End Sub
XLorate.com
Your PasteSpecial command might fail because it's spelled incorrectly. At any rate, if you've got a lot of rows, you should consider something faster than looping through them.
This uses AutoFilter to copy all rows meeting the criteria in one pass. It will also copy the header row. If that's not what you want, you can delete row 1 of the new worksheet after the copy:
Sub CopyStuff()
Dim SearchString As String
Dim Found As Boolean
Dim wsSource As Excel.Worksheet
Dim wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet
Dim LastRow As Long
Set wsSource = ActiveSheet
SearchString = "rejected"
With wsSource
Found = Application.WorksheetFunction.CountIf(.Range("E:E"), SearchString) > 0
If Not Found Then
MsgBox SearchString & " not found"
Exit Sub
End If
Set wbTarget = Workbooks.Add(1)
Set wsTarget = wbTarget.Worksheets(1)
wsTarget.Name = "Results"
.Range("E:E").AutoFilter
LastRow = .Range("E" & .Rows.Count).End(xlUp).Row
.Range("E:E").AutoFilter field:=1, Criteria1:=SearchString
.Range("E1:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Destination:=wsTarget.Range("A1")
End With
wbTarget.SaveAs Replace(ThisWorkbook.FullName, ".xlsm", "_rejected.xlsx")
wbTarget.Close
End Sub
I didn't use your code to create a new Excel instance, as I couldn't see why that would be needed here, and it could cause problems. (For example,yYou don't kill the instance in your original code.)