I am trying to copy information from one workbook to another existing workbook, but the wrong information is being added.
Sub Set_Open_ExistingWorkbook()
Dim UserRoleWkb As Workbook, ConfigWkb As Workbook, UserRoleWkst As Worksheet, ConfigWkst As Worksheet
Set UserRoleWkb = Workbooks.Open("C:\Users\cs\Desktop\Ar.xlsx")
**Set ConfigWkb = ActiveWorkbook**
Set UserRoleWkst = UserRoleWkb.Sheets("RS Users")
**Set ConfigWkst = ActiveWorkbook.ActiveSheet**
Dim i As Integer, j As Integer
j = 10 'user role
For i = 8 To 16 'config
If ConfigWkst.Cells(i, 2).Value <> "" Then
UserRoleWkst.Cells(j, 2).Value = ConfigWkst.Cells(i, 2).Value
j = j + 1
End If
Next i
End Sub
The part of the code with the ** around it is the issue. When I call the ActiveWorkbook and ActiveSheeet, it is grabbing the information from the UserRoleWkst (worksheet) rather than what I wanted: Configwkst.
I have tried this but will get errors on the ConfigWkst line and the code will not run:
Sub Set_Open_ExistingWorkbook()
Dim UserRoleWkb As Workbook, ConfigWkb As Workbook, UserRoleWkst As Worksheet, ConfigWkst As Worksheet
Set UserRoleWkb = Workbooks.Open("C:\Users\cs\Desktop\Ar.xlsx")
**Set ConfigWkb = ActiveWorkbook**
Set UserRoleWkst = UserRoleWkb.Sheets("RS Users")
**Set ConfigWkst = ConfigWkb.Sheets("Users")
Dim i As Integer, j As Integer
j = 10 'user role
For i = 8 To 16 'config
If ConfigWkst.Cells(i, 2).Value <> "" Then
UserRoleWkst.Cells(j, 2).Value = ConfigWkst.Cells(i, 2).Value
j = j + 1
End If
Next i
End Sub
Any help is appreciated. Thanks!
Once you open another workbook then that will become the ActiveWorkbook, so you need to get that reference before opening UserRoleWkb
Set ConfigWkb = ActiveWorkbook
Set ConfigWkst = ConfigWkb.ActiveSheet
Set UserRoleWkb = Workbooks.Open("C:\Users\cs\Desktop\Ar.xlsx")
Set UserRoleWkst = UserRoleWkb.Sheets("RS Users")
Related
Hi all and thanks in advance.
I currently have a VBA within my workbook to copy rows from "Demand Log" to "Change Log" when cells within column "O" have a specific value.
The VBA is working great, however I am now looking to split the two worksheets apart and have a separate workbook for each.
My question is - How can I change my VBA so that it copies and pastes between workbooks as opposed to between worksheets?
Please see my VBA code below:
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Demand Log").UsedRange.Rows.Count
J = Worksheets("Change Log").Cells(Worksheets("Change Log").Rows.Count, "B").End(xlUp).Row
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Change Log").Range) = 0 Then J = 0
End If
Set xRg = Worksheets("Demand Log").Range("O5:O" & I)
Application.ScreenUpdating = False
For K = xRg.Count To 1 Step -1
If CStr(xRg(K).Value) = "Change Team" Then
J = J + 1
With Worksheets("Demand Log")
Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Copy Destination:=Worksheets("Change Log").Range("A" & J)
Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Delete xlShiftUp
End With
End If
Next
Application.ScreenUpdating = True
You should refer to your worksheets and workbooks at the same time. So, instead of:
I = Worksheets("Demand Log").UsedRange.Rows.Count
You should type:
I = Workbooks("Book1").Worksheets("Demand Log").UsedRange.Rows.Count
anywhere in your code. For simplicity, you may set object variable, like:
Dim wb1 as Workbook
Set wb1 = Application.Workbooks("Book1")
or, better, set your worksheets as variables, for example:
Dim wsDemand as Worksheet
Set wsDemand = Workbooks("Book1").Worksheets("Demand Log")
and then you can use wsDemand instead of Worksheets("Demand Log") anywhere in your code.
Book1 is of course default workbook's name, your file has probably other name.
If the workbook is open then you can refer to it like this:
Workbooks("mybook.xls")[.method]
If the workbook is closed you need to open it: Workbooks.Open("C:\path\mybook.xls")[.method]
You can assign them to variables:
set wb = Workbooks("mybook.xls")
set wb = Workbooks.Open("C:\path\mybook.xls")
set ws = wb.Sheets("MySheet")
You can also get to the worksheet and assign it to a variable: (useful if you're working with a single sheet)
set ws = Workbooks("mybook.xls").Sheets("MySheet")
set ws = Workbooks.Open("C:\path\mybook.xls").Sheets("MySheet")
Untested, but give it a try:
Sub mysub()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
Dim wbDem As Workbook
Dim wbChg As Workbook
Dim wsDem As Worksheet
Dim wsChg As Worksheet
'Open/Get Workbook
If Application.Workbooks("Demand.xls") Is Nothing Then
Set wbDem = Application.Workbooks.Open("C:\path\Demand.xls")
Else
Set wbDem = Application.Workbooks("Demand.xls")
End If
'Open/Get Workbook
If Application.Workbooks("Change") Is Nothing Then
Set wbChg = Application.Workbooks.Open("C:\path\Change.xls")
Else
Set wbChg = Application.Workbooks("Change.xls")
End If
'Set Sheet Variables
Set wsDem = wbDem.Worksheets("Demand Log")
Set wsChg = wbChg.Worksheets("Change Log")
I = wsDem.UsedRange.Rows.Count
J = wsChg.Cells(wbChg.Rows.Count, "B").End(xlUp).Row
If J = 1 Then
If Application.WorksheetFunction.CountA(wbChg.Range) = 0 Then J = 0
End If
Set xRg = wsDem.Range("O5:O" & I)
Application.ScreenUpdating = False
For K = xRg.Count To 1 Step -1
If CStr(xRg(K).value) = "Change Team" Then
J = J + 1
With wsDem
Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Copy Destination:=wsChg.Range("A" & J)
Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Delete xlShiftUp
End With
End If
Next
Application.ScreenUpdating = True
End Sub
I am using two workbooks at a time. The first workbook is the current workbook and the second will be opened while programming execution. I have made the global objects of the workbooks and worksheets. I'm having issues with using the worksheets simultaneously. The error is ERROR: object variable or with block variable, not set. I have mentioned the error in the comment in the second subroutine.
Dim WB As Workbook
Dim WB2 As Workbook
Dim WKS As Worksheet
Dim WKS2 As Worksheet
Sub Button1_Click()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Set WB = ThisWorkbook
WB.Activate
fd.AllowMultiSelect = False
fd.Title = "Provide a title here."
fd.InitialFileName = ThisWorkbook.Path
If fd.Show() = True Then
strFile = fd.SelectedItems(1)
Set WB2 = Workbooks.Open(strFile)
Set WSK2 = WB2.Sheets("Schweitzer Analysis")
CalculateGrades
Else
MsgBox ("No file selected")
End If
End Sub
Sub CalculateGrades()
' first clear the contents where grades results can appear
clearGradesContents
Dim index As Integer ' for current sheet
Dim index2 As Integer ' for student sheet
Dim countCorrect As Integer ' to count no of correct answers
index = 2
index = 8
countCorrect = 0
' this first error here
' ERROR: object variable or with block variable not set
Set WKS = WB.ActiveSheet
Do While index <= 21
' the SECOND error shows here
If WKS.Cells(index, 2) = WKS2.Cells(index2, 3) Then
Count = Count + 1
Else
WKS.Cells(index, 5) = WKS2.Cells(index2, 3)
End If
If WKS.Cells(index, 3) = WKS2.Cells(index2, 4) Then
Count = Count + 1
Else
WKS.Cells(index, 6) = WKS2.Cells(index2, 4)
End If
index2 = index2 + 1
index = index + 1
Loop
End Sub
Sub clearGradesContents()
Range("E2:F21").Select
Selection.ClearContents
Range("I2:I3").Select
Selection.ClearContents
End Sub
EDIT: sorry for the previous answer, I hadn't seen your global declarations on top and I was sure it was because you hadn't declare it.
I think the issue is the following:
[...]
Set WB = ThisWorkbook
WB.Activate '<-- WB is the active workbook now
[...]
Set WB2 = Workbooks.Open(strFile) '<-- WB2 is the active workbook now!
Set WSK2 = WB2.Sheets("Schweitzer Analysis")
CalculateGrades '<-- going to next macro
[...]
Set WKS = WB.ActiveSheet '<-- ERROR: WB2 is the active workbook. WB can't have an active sheet if it's not the active workbook
Then of course, being WKS not correctly set, you can't execute this:
If WKS.Cells(index, 2) = WKS2.Cells(index2, 3) Then
I have no way to test it now, but I think that should be the issue.
To solve it,
If you really need WKS to be the ActiveSheet
Dim activeSheetName As String
...
Sub Button1Click()
...
Set WB = ThisWorkbook
WB.Activate
activeSheetName = WB.ActiveSheet.Name
...
End Sub
Sub CalculateGrades()
...
Set WKS = WB.Sheets(activeSheetName)
...
If you already know the name of the sheet you need
Just write:
Set WKS = WB.Sheets("your sheet")
instead of
Set WKS = WB.ActiveSheet
I want to transfer information to a target workbook from a source workbook when the target sheet name is the source sheet name.
I am realtively new to VBA, have been working with it for 2 weeks now and have literally googled my a$$ off. This website has proven to be the best hulp so far.
I have to transpose much information on a standard basis to a different format, where I want to fI want to automate this by the following code:
Sub Transfer()
Dim wbt As Workbook, wbs As Workbook 'wbt = workbook target, wbs = workbooksource
Dim wst As Worksheet, wss As Worksheet 'wbt = worksheet target, wbs = worksheet source
Dim wkt As Integer, wks As Integer, wke As Integer 'wkt = number in target sheet name, wks = number in source sheet name, wke = number in sheet name after which I want to stop transferring information
Dim vFile As Variant
Dim CCT As Range, CCS As Range
Set wbt = ActiveWorkbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
1, "Select One File To Open", , False)
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
Set wbs = ActiveWorkbook
wkt = 1
wks = 1
wke = 16
For Each wks In wbt.wst.("WK " & wkt)
If wks = wkt Then
wbt.wst("WK " & wkt).Range("K13:K63").Value = wbs.wss("WK " & wks).Range("G8:G58").Value
wbt.wst("WK " & wkt).Range("m13:m63").Value = wbs.wss("WK " & wks).Range("h8:h58").Value
wkt = wkt + 1
wks = wks + 1
If wke > wkt Then
wbs.Close (False)
Next
End Sub
This would be better already :
Sub Transfer()
Dim wbt As Workbook, wbs As Workbook 'wbt = workbook target, wbs = workbooksource
Dim wst As Worksheet, wss As Worksheet 'wbt = worksheet target, wbs = worksheet source
Dim wkt As Integer, wks As Integer, wke As Integer 'wkt = number in target sheet name, wks = number in source sheet name, wke = number in sheet name after which I want to stop transferring information
Dim vFile As Variant
Dim CCT As Range, CCS As Range
Set wbt = ActiveWorkbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
1, "Select One File To Open", , False)
If TypeName(vFile) = "Boolean" Then Exit Sub
Set wbs = Workbooks.Open(vFile)
' wkt = 1
' wks = 1
wke = 16
For Each wss In wbs.Sheets
For Each wst In wbt.Sheets
If wst.Name <> wss.Name Or CInt(Replace(wss.Name, "WK ", "")) >= wke Then
Else
wst.Range("K13:K63").Value = wss.Range("G8:G58").Value
'wbt.wst("WK " & wkt).Range("m13:m63").Value = wbs.wss("WK " & wks).Range("h8:h58").Value
' wkt = wkt + 1
' wks = wks + 1
End If
' If wke > wkt Then wbs.Close (False)
Next wst
Next wss
wbs.Close
Set wbs = Nothing
Set wbt = Nothing
End Sub
I don't really get your "wke", it is a number in the sheetname on which you want to limit your copy? If it is, the code might be changed enough already.
Btw, the Set is kind of a way to create quicker references for later use in code but you can't add arguments in there and you have to free them at the end of your code, Set ... = Nothing
Thanks for the reseponses. I have actually found a way to make the code rune fluently. The completed code is:
Option Explicit
Sub Data_Transfer_Ur1_1_1_to_UR1_2()
Dim wbt As Workbook, wbs As Workbook
Dim wst As Worksheet, wss As Worksheet
Dim vFile As Variant
Dim CCT As Range, CCS As Range
Dim array1(1 To 53) As String
Dim og As Integer, bg As Integer
'Set source workbook
Set wbt = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Dim j As Integer
DataTransferUserForm.Show
og = DataTransferUserForm.InputBoxOG.Value
bg = DataTransferUserForm.InputBoxBG.Value
For j = og To bg
array1(j) = "WK " + CStr(j)
Next j
Set wbs = ActiveWorkbook
Dim i As Integer
For i = 1 To UBound(array1)
wbt.Worksheets(array1(i)).Range("K13:K63").Value = wbs.Worksheets(array1(i)).Range("G8:G58").Value
wbt.Worksheets(array1(i)).Range("m13:m63").Value = wbs.Worksheets(array1(i)).Range("h8:h58").Value
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("J8:J58")
If CCS.Value > 0 Then
CCT.Value = "z"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("K8:K58")
If CCS.Value > 0 Then
CCT.Value = "i"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("L8:L58")
If CCS.Value > 0 Then
CCT.Value = "v"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("m8:m58")
If CCS.Value > 0 Then
CCT.Value = "o"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("n8:n58")
If CCS.Value > 0 Then
CCT.Value = "bv"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
wbt.Worksheets(array1(i)).Range("q13:q63").Value = wbs.Worksheets(array1(i)).Range("O8:O58").Value
wbt.Worksheets(array1(i)).Range("r13:r63").Value = wbs.Worksheets(array1(i)).Range("P8:P58").Value
Next i
wbs.Close (False)
wbt.Show
I have many files in a folder,
I have my code as below, is there any way to simplified my code so I do not need to keep copy and paste the same code but just continue updating the row number?
Sub FetchData()
Dim wbSource As Workbook
Dim shSource As Worksheet
Dim shDestin As Worksheet
Application.ScreenUpdating = False
'trace file from file path on B12
Workbooks.Open Filename:=Range("B12").Value & Sheets("Sheet1").Range("A1")
Set wbSource = ActiveWorkbook
Set shSource = wbSource.Sheets("Sheet1")
'current sheet display
Set shDestin = ThisWorkbook.Sheets("Sheet1")
'shDestion.Range display at where shSource.Range: the track data frm other file (NI)
shDestin.Range("E12") = shSource.Range("C2")
shDestin.Range("F12") = shSource.Range("D2")
shDestin.Range("G12") = shSource.Range("E2")
'shDestion.Range display at where shSource.Range: the track data frm other file (PD)
shDestin.Range("N12") = shSource.Range("C3")
shDestin.Range("O12") = shSource.Range("D3")
shDestin.Range("P12") = shSource.Range("E3")
'shDestion.Range display at where shSource.Range: the track data frm other file (AU)
shDestin.Range("W12") = shSource.Range("C4")
shDestin.Range("X12") = shSource.Range("D4")
shDestin.Range("Y12") = shSource.Range("E4")
‘copy from another workbook where filepath is at B11
Workbooks.Open Filename:=Range("B11").Value & Sheets("Sheet1").Range("A4")
Set wbSource = ActiveWorkbook
Set shSource = wbSource.Sheets("Sheet1")
'current sheet display
Set shDestin = ThisWorkbook.Sheets("Sheet1")
'shDestion.Range display at where shSource.Range: the track data frm other file (NI)
shDestin.Range("E11") = shSource.Range("C2")
shDestin.Range("F11") = shSource.Range("D2")
shDestin.Range("G11") = shSource.Range("E2")
'shDestion.Range display at where shSource.Range: the track data frm other file (PD)
shDestin.Range("N11") = shSource.Range("C3")
shDestin.Range("O11") = shSource.Range("D3")
shDestin.Range("P11") = shSource.Range("E3")
'shDestion.Range display at where shSource.Range: the track data frm other file (AU)
shDestin.Range("W11") = shSource.Range("C4")
shDestin.Range("X11") = shSource.Range("D4")
shDestin.Range("Y11") = shSource.Range("E4")
wbSource.Close False
End Sub
Something like this, but it's hard to tell exactly what you're doing in the code you posted...
For example what's the Activesheet when you start this code?
Option Explicit
Sub FetchData()
Dim shDestin As Worksheet
Application.ScreenUpdating = False
Set shDestin = ThisWorkbook.Sheets("Sheet1")
CopyFileContent Range("B12").Value & shDestin.Range("A1").Value, _
shDestin, 12
CopyFileContent Range("B11").Value & shDestin.Range("A4").Value, _
shDestin, 11
End Sub
Sub CopyFileContent(filePath As String, destSheet As Worksheet, destRow As Long)
Dim wbSource As Workbook, shSource As Worksheet, rngDest As Range
Set wbSource = Workbooks.Open(Filename:=filePath)
Set shSource = wbSource.Sheets("Sheet1")
Set rngDest = destSheet.Cells(destRow, 5).Resize(1, 3)
rngDest.Value = shSource.Range("C2:E2").Value
rngDest.Offset(0, 9).Value = shSource.Range("C3:E3").Value
rngDest.Offset(0, 18).Value = shSource.Range("C4:E4").Value
wbSource.Close False
End Sub
This question already has answers here:
Subscript out of range error in this Excel VBA script
(3 answers)
Closed 9 years ago.
This code still gives me an out of subscript error
Sub importData2()
ChDir "C:\Users\Desktop\Java"
Dim filenum(0 To 10) As Long
filenum(0) = 052
filenum(1) = 060
filenum(2) = 064
filenum(3) = 068
filenum(4) = 070
filenum(5) = 072
filenum(6) = 074
filenum(7) = 076
filenum(8) = 178
filenum(9) = 180
filenum(10) = 182
Dim sh1 As Worksheet
Dim rng As Range
Set rng = Range(Selection, ActiveCell.SpecialCells(xlLastCell))
Dim wb As Workbook
Set wb = Application.Workbooks("30_graphs_w_Macro.xlsm")
Dim sh2 As Worksheet
Dim rng2 As Range
Set rng2 = Range("A69")
Dim wb2 As Workbook
For lngposition = LBound(filenum) To UBound(filenum)
Set wb2 = Application.Workbooks.Open(filenum(lngposition) & ".csv")
wb2.Worksheets(filenum(lngposition)).rng.Copy wb.Worksheets(filenum(lngposition)).rng2.Paste
Next lngposition
my_handler:
MsgBox "All done."
End Sub
This still gives me an out of subscript error on the line:
Set wb2 = Application.Workbooks(filenum(lngposition) & ".csv")
I avoided using .active and .select. .select.
Subscript out of Range would raise on that line if the required file is not already open.
Since it seems unlikely that you would already have 11 files open, you probably need to use the Open method to open the necessary workbook inside your loop.
Set wb2 = Application.Workbooks.Open(filenum(lngposition) & ".csv").
Updated your code
Sub importData2()
ChDir "C:\Users\Desktop\Java"
Dim filenum(0 To 10) As String
Dim wb As Workbook
Dim sh1 As Worksheet
Dim rng As Range
Dim wb2 As Workbook
Dim sh2 As Worksheet
Dim rng2 As Range
filenum(0) = "052"
filenum(1) = "060"
filenum(2) = "064"
filenum(3) = "068"
filenum(4) = "070"
filenum(5) = "072"
filenum(6) = "074"
filenum(7) = "076"
filenum(8) = "178"
filenum(9) = "180"
filenum(10) = "182"
'## What workbook is this referring to?? This might cause problems later...
Set rng = Range(Selection, ActiveCell.SpecialCells(xlLastCell))
Set rng2 = Range("A69")
Set wb = Application.Workbooks("30_graphs_w_Macro.xlsm")
For lngposition = LBound(filenum) To UBound(filenum)
Set wb2 = Application.Workbooks.Open(filenum(lngposition) & ".csv")
Set sh1 = wb.Worksheets(filenum(lngposition))
Set sh2 = wb2.Worksheets(1) 'A CSV file only has 1 worksheet.
sh2.rng.Copy Destination:=sh1.Range(rng2.Address)
Next lngposition
my_handler:
MsgBox "All done."
End Sub
You should definitely have Set on the line when you assign worksheets:
Set sh1 = Worksheets(filenum(lngPosition))