I am trying to write a program which would take the information from a user selected grid and the information adjacent to it and send them to another workbook. However, whenever I compile, I would get the error 1004 (Automation). Can someone please point out where I have made a mistake in my code? It will be greatly appreciated.
Sub CopyItemsByLocation()
Dim wbThis As Workbook
Dim wsThis As Worksheet
Dim wbTarget As Workbook
Dim wsTarget As Worksheet
Dim strName As String
Dim i As Integer
Dim rng1 As Range
Set wbThis = ActiveWorkbook
Set wsThis = ActiveSheet
strName = ActiveSheet.Name
Set wbTarget = Workbooks.Open("C:\Users\Administrator\Desktop\Excel Testing\Excel Info Testing 2.xlsx")
Set wsTarget = wbTarget.Worksheets(strName)
Set rng1 = Selection
For i = 1 To 4
If i = 1 Then
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("E5") **'<~Error occurs here**
Set rng1 = rng1.Offset(0, 1)
ElseIf i = 2 Then
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("G5")
Set rng1 = rng1.Offset(0, 1)
ElseIf i = 3 Then
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("I5")
Set rng1 = rng1.Offset(0, 1)
Else
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("K5")
Set rng1 = rng1.Offset(0, 1)
End If
Next i
Application.CutCopyMode = False
wbTarget.Save
wbTarget.Close
Set wbTarget = Nothing
Set wbThis = Nothing
End Sub
rng1 is already a range so
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("E5")
should be
rng1.Copy Destination:=wsTarget.Range("E5")
Also might want to set rng1 before opening the other workbook
Reworked a bit:
Sub CopyItemsByLocation()
Const WB As String = "C:\Users\Administrator\Desktop\Excel Testing\Excel Info Testing 2.xlsx"
Dim wbTarget As Workbook
Dim wsTarget As Worksheet
Dim rng1 As Range
Set rng1 = Selection.Cells(1) 'in case of >1 cell selected
Set wbTarget = Workbooks.Open(WB)
Set wsTarget = wbTarget.Worksheets(rng1.Parent.Name)
rng1.Copy wsTarget.Range("E5")
rng1.Offset(0, 1).Copy wsTarget.Range("G5")
rng1.Offset(0, 2).Copy wsTarget.Range("I5")
rng1.Offset(0, 3).Copy wsTarget.Range("K5")
Application.CutCopyMode = False
wbTarget.Save
wbTarget.Close
End Sub
Related
first timer here, so go easy on me :)
Only been using VBA for a few months on work projects and I have hit a wall with what I can google, figured Id post the problem here.
I have a button that will open a source workbook and copy a specific range of cells from the source workbook to the destination workbook. This range of cells to be copied is determined by a for loop that starts at row 2 and loops to the last row of data. I have this code working in another project, but it appears to not want to run when its targeted at a different workbook.
Appreciate the help and any advice on the code in general would be welcome :)
Private Sub CommandButton1_Click()
Dim lastRow, i, erow As Integer
Dim filename As String
Dim fname As Variant
Dim dwbk, swbk As Workbook
Dim sws, dws As Worksheet
Dim r1 As Range
Set dwbk = ThisWorkbook
Set dws = dwbk.Sheets("Call OFF")
'On Error GoTo ErrHandling
'Application.ScreenUpdating = False
FileArray = Application.GetOpenFilename(Title:="Select file(s)", MultiSelect:=True)
For Each fname In FileArray
Set swbk = Workbooks.Open(fname)
Set sws = swbk.Sheets("Allocations")
lastRow = sws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
Range(Cells(i, "A"), Cells(i, "B")).Select
Selection.Copy
dwbk.Sheets("CALL OFF").Activate
erow = Worksheets("CALL OFF").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
Worksheets("CALL OFF").Cells(erow, 2).PasteSpecial xlPasteValues
swbk.Activate
Next i
Next
'Application.ScreenUpdating = True
' End If
'Done:
' Exit Sub
'
'ErrHandling:
' MsgBox "No file selected"
End Sub
Thanks.
You are not specifing the parent on the copy range.
Range(Cells(i, "A"), Cells(i, "B")).Select
Change to:
sws.Range(sws.Cells(i, "A"), sws.Cells(i, "B")).Copy
and remove the Selection.Copy line
But you can speed thing up a little and remove the loop by assigning the values directly:
Private Sub CommandButton1_Click()
Dim lastRow As Long, erow As Long
Dim filename As String
Dim fname As Variant
Dim dwbk As Workbook, swbk As Workbook
Dim sws As Worksheet, dws As Worksheet
Dim r1 As Range
Set dwbk = ThisWorkbook
Set dws = dwbk.Sheets("Call OFF")
'On Error GoTo ErrHandling
'Application.ScreenUpdating = False
FileArray = Application.GetOpenFilename(Title:="Select file(s)", MultiSelect:=True)
For Each fname In FileArray
Set swbk = Workbooks.Open(fname)
Set sws = swbk.Sheets("Allocations")
lastRow = sws.Range("A" & Rows.Count).End(xlUp).Row
erow = dws.Cells(dws.Rows.Count, 2).End(xlUp).Offset(1, 0).Row
dws.Cells(erow, 2).Resize(lastRow - 1, 2).Value = sws.Range(sws.Cells(2, 1), sws.Cells(lastRow, 2)).Value
Next fname
'Application.ScreenUpdating = True
' End If
'Done:
' Exit Sub
'
'ErrHandling:
' MsgBox "No file selected"
End Sub
I have around 30 sheets that I want this code to run in at the same time. I want to find "ABC" and delete the value of the cell next to it in all my worksheets.
I get my error from: Set rSearch = .**range**("A1", .range("A" & rows.count).end(x1up))
When I have specified "Sheet1" next to the "With" statement, it works, but I want this code to run on all my sheets.
Sub soek()
Dim rSearch As Range
Dim rFound As Range
Dim sign12 As String
Dim sheetsarray As Sheets
Set sheetsarray = ActiveWorkbook.Sheets(Array("sheet1", "sheet2", "sheet3"))
sign12 = "ABC"
With sheetsarray
Set rSearch = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Set rFound = rSearch.Find(What:=sign12, LookIn:=xlValues)
If rFound Is Nothing Then
Else
rFound.Offset(0, 1).ClearContents
End If
End With
End Sub
This question is a lot like: How to search for a string in all sheets of an Excel workbook?
But in my opinion, it's a lot easier to understand how to make code run on additional sheets reading my code than the code from the link above.
Try this (compilation of the comments above ;-)
Sub soek()
Dim rSearch As Range
Dim rFound As Range
Dim sign12 As String
Dim oWB As Workbook
Dim oWS As Worksheet
Set oWB = ThisWorkbook
sign12 = "ABC"
For Each oWS In oWB.Sheets
With oWS
Set rSearch = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Set rFound = rSearch.Find(What:=sign12, LookIn:=xlValues)
If rFound Is Nothing Then
Else
rFound.Offset(0, 1).ClearContents
End If
End With
Next oWS
End Sub
Hello i have this code my question is about inputbox. My inputbox is used for adressing to last folder where are my reports saved. But i want value of this inputbox (which is January 2018) also use in sub spracovanie2 to safe worbook in which is this code written. How can i make one inputbox to work for two sub precodures. I don't want to wrie same value two times. Can i make it public somehow?
Please comment if you think i don't expressing myself clearly.
Sub Spracovanie1()
Dim wb As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim mesiac_rok As String
mesiac_rok = InputBox("Mesiac/Rok")
Set wb = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws = wb.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks("?????.xlsm")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng2 = ws2.Range("B1")
ws.UsedRange.Copy Destination:=rng2
wb.SaveAs Filename:=("????????\" & mesiac_rok & "\??????.xlsx)"
wb.Close
End Sub
Sub Spracovanie2()
'
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim LastRow As Long
Set wb = Workbooks("Reporting AP Bwise source.xlsm")
Set ws = wb.Sheets("Check List Action plan Opr")
Set rng = ws.Range("B4").CurrentRegion
Set ws2 = wb.Sheets("OPR Action plans_TEMP")
rng.Copy Destination:=ws2.Range("A1")
ws2.Range("A1").CurrentRegion.UnMerge
LastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
ws2.Range("A1:AP" & LastRow).Sort Key1:=ws2.Range("N1:N" & LastRow), _
Order1:=xlAscending, Header:=xlYes
Set ws = wb.Sheets("OPEN AP")
ws.UsedRange.ClearContents
Set ws2 = wb.Sheets("CLOSED AP")
ws2.UsedRange.ClearContents
end sub
I'm trying to write a macro that will copy a row to another sheet if certain values are met. There are multiple possible destinations. This is what I've pieced together, but I'm sure it's messy. Basically, if in column 14 there is "N/A" and in column 8 there is "APP" then copy that to the APP tab. And so on for Angie, Cathy, etc.
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Reconciliation")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("APP")
Dim ws3 As Worksheet: Set ws3 = ThisWorkbook.Sheets("Angie")
Dim ws4 As Worksheet: Set ws4 = ThisWorkbook.Sheets("Cathy")
Dim ws5 As Worksheet: Set ws5 = ThisWorkbook.Sheets("Cory")
Dim ws6 As Worksheet: Set ws6 = ThisWorkbook.Sheets("Curt")
For Each i In ws1.Range("A1:A1000")
If ws1.Cells(i, 14) = "#N/A" Then
If ws1.Cells(i, 8) = "APP" Then
ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
End If
End If
Next i
This will copy the row if there's a sheet with a matching name:
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Reconciliation")
Dim ws
For Each i In ws1.Range("A1:A1000").Cells
If ws1.Cells(i.Row, 14).Value = cverr(2042) Then
Set ws = Nothing
On Error Resume Next
Set ws = ThisWorkbook.Sheets(ws1.Cells(i.Row, 8).Value)
on error goto 0
If Not ws Is Nothing Then
i.EntireRow.Copy ws.Rows(ws.Cells(ws.Rows.Count, 2).End(xlUp).Row + 1)
End If
on error goto 0
End If
Next i
I have an open workbook that has a bunch of macros in it, one of these macros is to copy data from this workbook and paste it into another workbook on a server. So far I can open the server workbook, and navigate to the right tab and cell but I cannot paste the data... My code is below:
Sub aggregate()
Dim m As String
Dim t As Integer
'opened workbook
Sheets("Month Count").Select
range("A2").Select
Do
m = ActiveCell.Value
t = ActiveCell.Offset(0, 1).Value
Set xl = CreateObject("Excel.Application")
Set xlwbook = xl.Workbooks.Open("\\LOCATIONOFOTHERWORKBOOKONSERVER")
xl.Visible = True
xlwbook.Worksheets("A").range("A2").Select
xlwbook.ActiveCell.Value = m **this is where my code breaks.**
xlwbook.ActiveCell.Offset(1, 0).Value = t
'HOW TO SAVE FILE AND CLOSE FILE?
Windows("GOBACKTOFIRSTWORKBOOK").Activate
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Value = "THE END"
End Sub
Something like below which will find a range from A2 to a cell contain "THE END" in column A of a sheet called "Month Count" in the ActiveWorbook, then open a second workbook ( I used C:\test\other.xlsm", goto sheet "A", and then put
A2 from the first book into A2 of the second book,
B2 from the first book into A3 in the second book,
A3 from the first book into A4 in the second book,
B3 from the first book into A5 in the second book etc
Note that in your code you are currently opening a new Excel instance, you should work on both workbooks in the same instance so that they can "talk"
Sub aggregate()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim lngRow As Long
Dim lngCalc As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
End With
Set Wb1 = ActiveWorkbook
Set ws1 = Wb1.Sheets("Month Count")
Set rng1 = ws1.Columns("A").Find("THE END", , xlValues, xlWhole)
If rng1 Is Nothing Then
MsgBox "Did not find marker cell"
GoTo QuickExit
End If
Set rng1 = ws1.Range(ws1.[a2], ws1.Cells(rng1.Row, "A"))
Set Wb2 = Workbooks.Open("C:\test\other.xlsm")
Set ws2 = Wb2.Sheets("A")
For Each rng2 In rng1
ws2.[a2].Offset(lngRow, 0) = rng2
ws2.[a2].Offset(lngRow + 1, 0) = rng2.Offset(0, 1)
lngRow = lngRow + 2
Next
Wb2.Save
Wb2.Close
Wb1.Activate
QuickExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
End Sub
there is no point "activating" your workbooks.
you don't need to instantiate a second Excel if your macro is already running in Excel.
it would be much faster to do in one shot
I suspect your error comes from the fact xlwbook has not been activated when you use xlwbook.ActiveCell.
Below is my proposal for your copy/paste thing, the one by one way (or I should say 2 by 2).
Sub aggregate2()
Dim rngSource As Range
Dim rngDest As Range
Dim xlwbook As Workbook
Set rngSource = Sheets("Month Count").Range("A2:B2")
Set xlwbook = Workbooks.Open("\\LOCATIONOFOTHERWORKBOOKONSERVER")
Set rngDest = xlwbook.Range("A2:B2")
Do
rngDest.Value = rngSource.Value
Set rngSource = rngSource.Offset(1, 0)
Set rngDest = rngDest.Offset(1, 0)
Loop Until rngDest.Cells(1, 1) = "THE END"
xlwbook.close
End Sub