Since I am new to VBA I created a code which can open a .csv file and copy data from .csv to an excel file without opening both.
Actually it works for excel files but When I use a .csv file it displays me an error message "SUBSCRIPT OUT OF RANGE".How do I solve this? Thank You!
Sub Copywb1()
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Setwkb1 = ThisWorkbook
Setwkb2 = Workbooks.Open("C:\Desktop\AAA.xlsx")
Setwkb1 = Workbooks.Open("C\Reports\BBB.csv")
Setsht1 = wkb1.Sheets("Reports")
Setsht2 = wkb2.Sheets("Fees")
sht1.Range("A1:BM9").Copy
sht2.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
wkb2.Close True
wkb1.Close True
End Sub
Here's a working example I had that you should able to to adapt to your needs fairly easily:
Sub demo_loadDataFromCSV()
Const csvFile = "x:\mypath\myfile.csv"
Dim ws As Worksheet, csv As Workbook, cCount As Long, cName As String
' Application.ScreenUpdating = False 'keep these commented-out until...
' Application.DisplayAlerts = False ' ...done testing/troubleshooting!
Set ws = ThisWorkbook.ActiveSheet 'remember where we parked
Workbooks.Open csvFile 'open the csv
Set csv = ActiveWorkbook 'create object of csv workbook
cName = csv.Name 'get name of csv while its open
ActiveSheet.Columns("A:B").Copy 'copy columns A and B
ws.Activate 'go back to the first sheet
ws.Range("A1").PasteSpecial xlPasteValues 'paste values
cCount = Selection.Cells.Count 'count pasted cells
csv.Close 'close CSV
Application.DisplayAlerts = True 're-enable alerts
Application.ScreenUpdating = True 'resume screen updates
MsgBox cCount & " cells were copied from " & cName _
& " to " & ws.Parent.Name, vbInformation, "Done"
End Sub
More Information:
MS Docs : Workbooks.Open Method (Excel)
MS Docs : Range.PasteSpecial Method (Excel) (Excel)
CFO : Referring to Other Worksheets or Workbooks in Excel VBA
Code VBA : Set Workbook variable
Here are the minor changes in code, now it will select the new workbook and paste the data in the selected sheet.
Sub demo_loadDataFromCSV()
Const csvFile = "C:\Users\PC\Downloads\R1C2.txt"
Dim ws As Worksheet, csv As Workbook, cCount As Long, cName As String
Dim ws2 As Worksheet
' Application.ScreenUpdating = False 'keep these commented-out until...
' Application.DisplayAlerts = False ' ...done testing/troubleshooting!
Set ws = ThisWorkbook.ActiveSheet 'remember where we parked
Workbooks.Open csvFile 'open the csv
Set csv = ActiveWorkbook 'create object of csv workbook
'to open new workbook
Filename = Application.GetOpenFilename(, , "Browse for workbook")
cName = csv.Name 'get name of csv while its open
ActiveSheet.Columns("A:B").Copy 'copy columns A and B
'Open workbook
Workbooks.Open Filename
'Go to sheets Fees
Set test = ActiveWorkbook.Sheets("Fees")
test.Activate
test.Range("A1").PasteSpecial xlPasteValues 'paste values
cCount = Selection.Cells.Count 'count pasted cells
csv.Close 'close CSV
Application.DisplayAlerts = True 're-enable alerts
Application.ScreenUpdating = True 'resume screen updates
MsgBox cCount & " cells were copied from " & cName _
& " to " & ws.Parent.Name, vbInformation, "Done"
End Sub
Related
I'm trying to:
Copy cell "B2:C2" from every workbook in a folder from the "Results" worksheet.
Paste the value into Cell A1:A2 Sheet1 in workbook "x"in the same folder.
I think I know how to open and do something to every workbook within a folder.
Option Explicit
Sub LoopThroughDirectory()
Dim MyFile As String
Dim WorkbookCounter As Long
WorkbookCounter = 1
Dim Filepath As String
Dim wb As Workbook
Dim RowCounter As Long
RowCounter = 1
Filepath = "C:\Test\"
Application.ScreenUpdating = False
MyFile = Dir(Filepath)
'Opens workbooks located C:\Test\ in order
Do While Len(MyFile) > 0
Set wb = Workbooks.Open(Filepath & MyFile)
Application.DisplayAlerts = False
'Copy cells B2 & C2 from the results worksheet
ThisWorkbook.Worksheets("x").Range(Cells(RowCounter, 1), Cells(RowCounter, 2)).Value = _
wb.Worksheets("Results").Range("B2:C2").Value
'Close wb most recently opened
wb.Close SaveChanges:=False
Application.CutCopyMode = False
WorkbookCounter = WorkbookCounter + 1
If WorkbookCounter > 1000 Then
Exit Sub
End If
MyFile = Dir
RowCounter = RowCounter + 1
Loop
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub
Update: With help in the comments below the above code now correctly loops through the correct folder and updates cell A1:A2.
Instead of overwriting cell A1:A2 I'd like to paste the copied text one line down.
i.e. Workbook 1 = A1:A2, Workbook 2 = B1:B2, etc
I don't see any check to make sure you are not trying to open ThisWorkbook and there is no check to see if there is a Results worksheet in the source workbook; in fact there is no check to ensure that you are trying to open a workbook at all, you could be trying to open a JPG.
Further error control could be added to ensure that you are not trying to open another workbook that is already open. I suspect that after all the testing, you might have a few.
Option Explicit
Sub LoopThroughDirectory()
Dim myFile As String, filepath As String
Dim wbc As Long, ws As Worksheet, wb As Workbook
wbc = 0
filepath = "C:\Test\"
'Application.ScreenUpdating = False
'only try to open workbooks
myFile = Dir(filepath & "*.xls*")
'Opens workbooks located C:\Test\ in order
Do While Len(myFile) > 0
'make sure myFile isn't ThisWorkbook
If Split(myFile & ".", ".")(0) <> Split(ThisWorkbook.Name & ".", ".")(0) Then
Set wb = Workbooks.Open(Filename:=filepath & myFile, ReadOnly:=True)
'Application.DisplayAlerts = False
'check if there is a Results worksheet
On Error Resume Next
Set ws = wb.Worksheets("Results")
On Error GoTo 0
If Not ws Is Nothing Then
'transfer cells B2 & C2 from the results worksheet
With ws.Range("B2:C2")
ThisWorkbook.Worksheets("x").Range("A1").Offset(wbc, 0).Resize(.Rows.Count, .Columns.Count) = .Value
End With
End If
'Close wb most recently opened
wb.Close SaveChanges:=False
wbc = wbc + 1
If wbc > 1000 Then Exit Do
End If
Set ws = Nothing
myFile = Dir
Loop
ActiveWorkbook.Save
'Application.ScreenUpdating = True
End Sub
I have a tab (Tab A) in my workbook that has links to another tab (Tab B and Tab C) that VBA inserts with Application.GetOpenFilename. When I run the macro I get #REF! in Tab A for the formulas on that tab (the formulas reference the inserted tabs ie Tab B and Tab C). How can I prevent this from happening and to keep the formulas on Tab A intact?
Here is my code:
Sub Data_Tab()
'
' Data Tab Macro
Dim ws As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("CC_DMSR").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "CC_DMSR"
Application.DisplayAlerts = True
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range
Set wb1 = ActiveWorkbook
Set PasteStart = [CC_DMSR!A1]
Sheets("CC_DMSR").Select
Cells.Select
Selection.ClearContents
MsgBox "Please select the CC DMSR File"
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a Report to Parse", _
FileFilter:="Report Files *.xlsx (*.xlsx),")
If FileToOpen = False Then
MsgBox "No File Specified.", vbExclamation, "ERROR"
Exit Sub
Else
Set wb2 = Workbooks.Open(Filename:=FileToOpen)
For Each Sheet In wb2.Sheets
With Sheet.UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
Next Sheet
End If
wb2.Close
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Submitted_DMSR").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "Submitted_DMSR"
Application.DisplayAlerts = True
Set wb1 = ActiveWorkbook
Set PasteStart = [Submitted_DMSR!A1]
Sheets("Submitted_DMSR").Select
Cells.Select
Selection.ClearContents
MsgBox "Please select the Submitted DMSR File"
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a Report to Parse", _
FileFilter:="Report Files *.xlsx (*.xlsx),")
If FileToOpen = False Then
MsgBox "No File Specified.", vbExclamation, "ERROR"
Exit Sub
Else
Set wb2 = Workbooks.Open(Filename:=FileToOpen)
For Each Sheet In wb2.Sheets
With Sheet.UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
Next Sheet
End If
wb2.Close
ActiveWorkbook.RefreshAll
ActiveSheet.PivotTables("PivotTable2").PivotCache.MissingItemsLimit = _
xlMissingItemsNone
ActiveSheet.PivotTables("PivotTable1").PivotCache.MissingItemsLimit = _
xlMissingItemsNone
With Sheets("Comparison").PivotTables("PivotTable1").PivotFields("TASK/TB")
.PivotItems("(blank)").Visible = False
End With
With Sheets("Comparison").PivotTables("PivotTable2").PivotFields("TASK/TB")
.PivotItems("(blank)").Visible = False
End With
Dim bottomrow As Long
Sheets("Comparison").Select
bottomrow = Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
Range("D4:J4").AutoFill Destination:=Range("D4:J" & bottomrow), Type:=xlFillDefault
Application.ScreenUpdating = True
Call sourceSheet.Activate
End Sub
I'm not sure if just opening wb2 is introducing the REF errors or the insertion of the sheets.
E.g.
If you open workbook1, which has a formula which contains a reference to workbook2, and workbook2 is then opened in Protected Mode (per default settings), Excel will introduce REF errors in any cells with references to workbook2 (due to Protected mode).
If the above is your problem, then one way might be to add wb2 as trusted document or location, or Excel>File>Options>And turn off protected mode (inadvisable).
Irrespective of the above, other solution is you using:
Range.Find and loop through all cells with references to the
sheet(s) that will be inserted
Temporarily replace the first '=' with ' =' in these cells, which should turn the formula into a string value.
You then insert the sheets you want (string values can't experience REF errors)
Then replace ' =' with '=' to convert string back to Excel formula.
You could set a range object in step 1 that could then be reused in step 2 and 3.
I have a source excel file which contains worksheets starting with "TYPICAL" name.
I also have a code to export the "TYPICAL" worksheet to another Excel file using the Getopenfile name. As a part of code, I have to rename the source worksheet as value contained in cell "E3" and current date.
Attached code works fine for me, but I can not select multiple "TYPICAL" sheets and export. Can any one suggest a way to loop through the selected work sheets?
Sub export()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sht As Worksheet
Dim dt As String
Dim mntg As String
Set wb1 = ActiveWorkbook
Set Sht = Selection.Worksheet
Dim shtname As String
'
shtname = CStr(Sht.Name)
dt = CStr(Format(Date, "DDMMYY"))
If Left(shtname, 7) = "TYPICAL" Then
mntg = CStr(Range("E2").Value)
Sht.Name = mntg & "_" & dt
FileToOpen = Application.GetOpenFilename _
(Title:="choose a Excel file to insert selected Typical File", _
FileFilter:="*.xlsx (*.xlsx),")
'
If FileToOpen = False Then
MsgBox "No File Specified.", vbExclamation, "ERROR"
Sht.Name = shtname
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
Else
Set wb2 = Workbooks.Open(Filename:=FileToOpen)
End If
wb1.Activate
Sht.Copy After:=wb2.Sheets(wb2.Sheets.Count)
wb2.Save
wb2.Close
Else
MsgBox "This is not a Typical File for Export", vbExclamation, "ERROR"
End If
Sht.Name = shtname
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Ok so I have a current workbook (Original Workbook) with one Sheet.
I would like to open an existing workbook (Data Workbook) and copy all of the contents in Sheet 1 of 'Data Workbook', then paste everything into Sheet "Main" of 'Original Workbook'.
At the end of this process I would like to close the 'Data Workbook' So far I have the following code.
however it gives me an error message
"Run-time error'1004': Cannot paste that macro formula onto a worksheet":
Sub ImportData()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range
Set wb1 = ActiveWorkbook
Set PasteStart = [Main!A1]
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a Report to Parse", _
FileFilter:="Report Files *.xls (*.xls),")
If FileToOpen = False Then
MsgBox "No File Specified.", vbExclamation, "ERROR"
Exit Sub
Else
Set wb2 = Workbooks.Open(Filename:=FileToOpen)
For Each Sheet In wb2.Sheets
With Sheet.UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
Next Sheet
End If
wb2.Close
End Sub
Hello please refer the code below and make changes according to your need. It does what you need.
Option Explicit
Sub import()
Dim filename As String
Dim curfilename As String
curfilename = ThisWorkbook.Name
filename = Application.GetOpenFilename
Application.ScreenUpdating = False
Dim x As Workbook
Set x = Workbooks.Open(filename)
With Sheets("1")
x.Sheets("1").Range("A1:Z10000").Copy '/Provide the range
End With
Dim y As Workbook
Set y = Workbooks(curfilename)
With Sheets("Main")
y.Sheets("Main").Range("A1").PasteSpecial xlPasteFormats
Application.DisplayAlerts = False
End With
x.Close SaveChanges:=False
Range("A1").Select
End Sub
I have a work sheet named Final_Sheet, I want to create a button on that sheet and execute the following operation
Select Cell Range A1:D30 and pickup the values from cell only and create a new Excel file and paste the copied cell values into Sheet1 of created excel file. I am able to o this much, further I can't understand what to do can anybody please help me out?
Private Sub Button1_Click()
Dim rownum As Integer
Dim selection As Range
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
rownum = InputBox("Row No to Copy :", "OK")
selection = ActiveSheet.Range(Cells(1, 1), Cells(rownum, 10)).Select
selection.Copy
Flname = InputBox("Enter File Name :", "Creating New File...")
MsgBox ("Output File Created Successfully")
If Flname <> "" Then
Set NewWkbk = Workbooks.Add
ThisWorkbook.Sheets(1).Range("D1:D30").Copy Before:=NewWkbk.Sheets(1)
NewWkbk.Sheet(1).Select
Cells(1, 1).Activate
selection.PasteSpecial xlPasteValues
NewWkbk.SaveAs ThisWorkbook.Path & "\" & Flname
ActiveWorkbook.Close
End If
End Sub
The code below should do as you've asked.
EDIT: Pastes values only
Private Sub Button1_Click()
'Dim Variables
Dim ws As Worksheet
Dim rng As Range
Dim wbNew As Workbook, wbCurrent As Workbook
Dim strFileName As String
'Assign object variables
Set wbCurrent = ActiveWorkbook
Set ws = wbCurrent.ActiveSheet
Set rng = ws.Range("A1:D30") 'Amend range if needed
'Get desired file path from user
strFileName = InputBox("Enter File Name: ", "Creating New File...")
If strFileName <> "" Then
'Create new Workbook and paste rng into it
Set wbNew = Workbooks.Add
rng.Copy
wbNew.Sheets(1).Range("A1:D30").PasteSpecial xlValues
'Save new workbook using desired filepath
wbNew.SaveAs wbCurrent.Path & "\" & strFileName
End If
End Sub
It wasn't clear to me from the question which workbook you wished to close with ActiveWorkbook.Close but you could easily add wbNew.Close or wbCurrent.Close below wbNew.SaveAs ... as required.