I'm exporting to Excel and I need to insert numbers in front of cells that allready have numbers in It. Here is my full code:
Private Sub cmdExport_Click()
Dim Results As Recordset
Dim Numbering As Integer
Dim FileName As String
Dim FilePath As String
Dim wb As Excel.Workbook
Dim XcelFile As Excel.Application
FileName = "TEST" & Format(Date, "dd/mm/yyyy") & ".xlsx"
FilePath = CurrentProject.Path & "\" & FileName
Set XcelFile = New Excel.Application
Set wb = XcelFile.Workbooks.Add
Set Results = Forms![MyForm].Form.RecordsetClone
With wb
XcelFile.ScreenUpdating = False
For Numbering = 0 To Results.Fields.Count - 1
XcelFile.Cells(1, Numbering + 1).Value = Results.Fields(Numbering).Name
Next Numbering
Results.MoveFirst
XcelFile.Range("A2").CopyFromRecordset Results
For Each cell In XcelFile.Range("A:A")
cell.Value = "100" & cell.Value
Next cell
.SaveAs FileName:=FilePath, FileFormat:=51
XcelFile.ScreenUpdating = True
End With
wb.Close
Set XcelFile = Nothing
End Sub
As you see, I have tried with this:
For Each cell In XcelFile.Range("A:A")
cell.Value = "100" & cell.Value
Next cell
But, unfortunally, nothing happens. How could I solve this?
For Each cell In XcelFile.Range("A:A")
should be
Dim sh As Excel.Worksheet
Set sh = wb.ActiveSheet
For Each cell In sh.Range("A:A")
me thinks.
This applies for all other places where you have XcelFile.Cells now, change them to sh.Cells.
Note:
Dim XcelFile As Excel.Application
is a really really confusing name, IMHO.
Related
I would like to combine sheets with the same name & format from multiple files into a single summary sheet. I used this code to do it but I found it won't copy any filtered data or link cells. I also tried a couple codes to remove the filter, and the copied data becomes uncontinuous. Could someone look into this and help me? Thanks!
Sub Multiple_to_One()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Dim lo As ListObject
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xlsm")
AWbName = ActiveWorkbook.Name
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
With Workbooks(1).ActiveSheet
Wb.Sheets(13).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Wb.Close False
End With
End If
MyName = Dir
Loop
MsgBox "All done.", vbInformation, "bingo"
End Sub
This is a bit of a brute force method, but seems to work:
Sub Summarize()
Dim sourcePath As String
Dim sourceName As String
Dim sourceWorkbook as Workbook ' Workbook to be copied
Dim sourceSheet as Worksheet
Dim thisWorkbookName as String
Dim copyCell as Range
Dim sourceBase as Range ' Summary starts here
Application.ScreenUpdating = False
sourcePath = ActiveWorkbook.Path
thisWorkbookName = ActiveWorkbook.Name
sourceName = Dir(MyPath & "\" & "*.xlsm")
Set sourceBase = Workbooks(1).ActiveSheet.Range("A1") ' Set to what you want
Do While sourceName <> ""
If sourceName <> thisWorkbookName Then
Set sourceWorkbook = Workbooks.Open(sourcePath & "\" & sourceName)
Set sourceSheet = sourceWorkbook.Sheets(13)
For Each copyCell In sourceSheet.UsedRange
copyCell.Copy sourceBase.Offset(copyCell.Row - 1, copyCell.Column - 1)
Next
Set sourceBase = sourceBase.Offset(sourceSheet.UsedRange.Rows.Count)
Set copyCell = Nothing
Set sourceSheet = Nothing
sourceWorkbook.Close False
End If
sourceName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "All done.", vbInformation, "bingo"
End Sub
I'm just manually copying every cell in the used range into the target sheet. The base cell gets reset after each sheet, so it should just keep appending to the target sheet.
Caveat
I've only tested the inner code in my own sheet. I made adjustments on the fly to fit everything into your original logic. The entire function above should replace your original function. If you have errors, it's because I mistyped something. My apologies.
I set the autofiltermode to False. This worked in my case.
Wb.Sheets(13).AutoFilterMode = False
Here is the modified code.
Sub Multiple_to_One()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Dim lo As ListObject
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xlsm")
AWbName = ActiveWorkbook.Name
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Wb.Sheets(13).AutoFilterMode = False
ThisWorkbook.Activate
With Workbooks(1).ActiveSheet
Wb.Sheets(13).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Wb.Close False
End With
End If
MyName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "All done.", vbInformation, "bingo"
End Sub
I am trying to copy specific collections sheets within an excel workbook in separate workbooks. Not being a vba coder I have used and adapted code found here and other resource sites. I believe I am now very close having grasped the basic concepts but cannot figure out what i am doing wrong, triggering the below code causes the first new workbook to be created and the first sheet inserted but breaks at that point.
My code is below, additional relevant info - there is a sheet called 'List' which has a column of names. Each name on the list has 2 sheets which I am trying to copy 2 by 2 into new sheet of the same name. the sheets are labelled as the name and the name + H (e.g Bobdata & BobdataH)
Sub SheetCreate()
'
'Creates an individual workbook for each worksname in the list of names.
'
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sht As Object
Dim strSavePath As String
Dim sname As String
Dim relativePath As String
Dim ListOfNames As Range, LRow As Long, Cell As Range
With ThisWorkbook
Set ListSh = .Sheets("List")
End With
LRow = ListSh.Cells(Rows.Count, "A").End(xlUp).Row '--Get last row of list.
Set ListOfNames = ListSh.Range("A1:A" & LRow) '--Qualify list.
With Application
.ScreenUpdating = False '--Turn off flicker.
.Calculation = xlCalculationManual '--Turn off calculations.
End With
Set wbSource = ActiveWorkbook
For Each Cell In ListOfNames
sname = Cell.Value & ".xls"
relativePath = wbSource.Path & "\" & sname
Sheets(Cell.Value).Copy
Set wbDest = ActiveWorkbook
Application.DisplayAlerts = False
ActiveWorkbook.CheckCompatibility = False
ActiveWorkbook.SaveAs Filename:=relativePath, FileFormat:=xlExcel8
Application.DisplayAlerts = True
wbSource.Activate
Sheets(Cell.Value & "H").Copy after:=Workbooks(relativePath).Sheets(Cell.Value)
wbDest.Save
wbDest.Close False
Next Cell
MsgBox "Done!"
End Sub
You can try to change
Sheets(Cell.Value & "H").Copy after:=Workbooks(relativePath).Sheets(Cell.Value)
to
Sheets(Cell.Value & "H").Copy after:=wbDest.Sheets(Cell.Value)
Also it would be good idea to check if file already exists in selected location. For this you can use function:
Private Function findFile(ByVal sFindPath As String, Optional sFileType = ".xlsx") As Boolean
Dim obj_fso As Object: Set obj_fso = CreateObject("Scripting.FileSystemObject")
findFile = False
findFile = obj_fso.FileExists(sFindPath & "/" & sFileType)
Set obj_fso = Nothing
End Function
and change sFileType = ".xlsx" to "*" or other excet file type.
This was the code i created to create a new workbook and then copy sheet contents from existing one to the new one. Hope it helps.
Private Sub CommandButton3_Click()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
TryAgain:
Flname = InputBox("Enter File Name :", "Creating New File...")
MsgBox Len(Flname)
If Flname <> "" Then
Set NewWkbk = Workbooks.Add
ThisWorkbook.Sheets(1).Range("A1:J100").Copy
NewWkbk.Sheets(1).Range("A1:J100").PasteSpecial
Range("A1:J100").Select
Selection.Columns.AutoFit
AddData
Dim FirstRow As Long
Sheets("Sheet1").Range("A1").Value = "Data Recorded At-" & Format(Now(), "dd-mmmm-yy-h:mm:ss")
NewWkbk.SaveAs ThisWorkbook.Path & "\" & Flname
If Err.Number = 1004 Then
NewWkbk.Close
MsgBox "File Name Not Valid" & vbCrLf & vbCrLf & "Try Again."
GoTo TryAgain
End If
MsgBox "Export Complete Close the Application."
NewWkbk.Close
End If
End Sub
Im importing alot of sheetnames from different files using this VBA:
Sub ImportSheets()
Dim sPath As String
Dim sFname As String
Dim wBk As Workbook
Dim wSht As Variant
Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = InputBox("Enter a full path to workbooks")
ChDir sPath
sFname = InputBox("Enter a filename pattern")
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal)
wSht = InputBox("Enter a worksheet name to copy")
Do Until sFname = ""
Set wBk = Workbooks.Open(sFname)
Windows(sFname).Activate
Sheets(wSht).Copy After:=ThisWorkbook.Sheets(1)
ActiveSheet.Name = ActiveSheet.Range("A9")
wBk.Close False
sFname = Dir()
Loop
ActiveWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Right now the net sheetname is whatever value that is written in A9, is there a way i can change that, so the sheet will be renamed to the filename it is imported from?
Alternative solution could be to rename it "Import" & Suffix, however im not sure how to add the suffix 1-1000 ect.
You have the workbook name as sFname. Peel off the extension and use that.
ActiveSheet.Name = left(sFname, instrrev(sFname, chr(46))-1)
In order to have the same name as the Excel file, then simply try this:
ActiveSheet.Name = wBk.Name
If you want to have the same name as the worksheet, from which you are copying,
instead of ActiveSheet.Name = ActiveSheet.Range("A9"), this is the code you need:
ActiveSheet.Name = Worksheets(wSht).Name
It will take exactly the correct name. Or even ActiveSheet.Name = wSht, as far as you are specifying it exactly through the InputBox.
In general, before trying to copy the corresponding worksheet, you may check whether it exists and only do the copy if it is there. This is one way (see the link below for others) to do it:
If WorksheetExists(wSht) Then
Sheets(wSht).Copy After:=ThisWorkbook.Sheets(1)
ActiveSheet.Name = ActiveSheet.Range("A9")
End If
Function WorksheetExists(sName As String) As Boolean
WorksheetExists = Not WorksheetFunction.IsErr(Evaluate("'" & sName & "'!A1"))
End Function
In order to get Import + counter, try something like this in your code:
Option Explicit
Public Sub TestMe()
Dim importName As String
Dim cnt
Do Until cnt = 10
cnt = cnt + 1
importName = "Import" & cnt
Debug.Print importName
Loop
End Sub
Simply make sure that you always increment +1 the worksheet's name.
Test or check if sheet exists
I need to generate many .xls files
renamed as the name contained in row A1, A2, A3 ....
example: NAME1.xls, NAME2.xls ...
and the new generated file must contain only the cells contained in the markers ####
(see IMG...cellD4:T32)
the markers change manually entered by me.
I tried this code only to save new .xls files
but it does not work....I do not know how to do the rest
Private Sub CommandButton1_Clickl()
Dim path As String
Dim filename1 As String
path = "C:\"
filename1 = Range("A1").Text
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=path & filename1 & ".xls", FileFormat:=x1OpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Sub
Okay here ya go. This should grab the chunk of the original workbook you're looking for and save it as multiple new workbooks.
Option 1 removes formatting
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim arr() As Variant
arr = wksht.Range("C3:U33").value
Dim wb As Workbook
Dim i As Long
For i = 1 To ActiveSheet.Range("A1").End(xlDown).Row
Set wb = Application.Workbooks.Add
wb.Sheets(1).Range("A1", Cells(UBound(arr), UBound(arr, 2))).value = arr
wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
wb.Close
Next i
End Sub
Option 2 keeps formatting
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim dataRange As Range
Set dataRange = wksht.Range("C3", wksht.UsedRange.SpecialCells(xlCellTypeLastCell))
Dim wb As Workbook
Dim i As Long
For i = 1 To wksht.Range("A" & wksht.rows.count).End(xlUp).Row
Set wb = Application.Workbooks.Add
dataRange.Copy wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.rows.count, dataRange.Columns.count))
wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
wb.Close
Next i
End Sub
but note that the starting point is still C3 based on the example given.
Option 3 keeps formatting and selects the range between the 2 cells with #### in them
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim rngeStart
Dim rngeEnd
Set rngeStart = wksht.UsedRange.Find(What:="####", LookIn:=xlValues, LookAt:=xlWhole)
Set rngeEnd = wksht.UsedRange.FindNext(After:=rngeStart)
Dim dataRange As Range
Set dataRange = wksht.Range(rngeStart, rngeEnd)
Dim wb As Workbook
Dim i As Long
For i = 1 To wksht.Range("A" & wksht.rows.count).End(xlUp).Row
Set wb = Application.Workbooks.Add
dataRange.Copy wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.rows.count, dataRange.Columns.count))
wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
wb.Close
Next i
End Sub
Option 5 keeps row heights and column widths
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim rngeStart
Dim rngeEnd
Set rngeStart = wksht.UsedRange.Find(What:="####", LookIn:=xlValues, LookAt:=xlWhole)
Set rngeEnd = wksht.UsedRange.FindNext(After:=rngeStart)
Dim dataRange As Range
Set dataRange = wksht.Range(rngeStart, rngeEnd)
Dim newDataRange As Range
Dim wb As Workbook
Dim i As Long
Dim j As Long
Dim k As Long
For i = 1 To wksht.Range("A" & wksht.Rows.Count).End(xlUp).Row
Set wb = Application.Workbooks.Add
Set newDataRange = wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.Rows.Count, dataRange.Columns.Count))
dataRange.Copy newDataRange
For j = 1 To dataRange.Columns.Count
newDataRange.Cells(1, j).ColumnWidth = dataRange.Cells(1, j).ColumnWidth
Next j
For k = 1 To dataRange.Rows.Count
newDataRange.Cells(k, 1).RowHeight = dataRange.Cells(k, 1).RowHeight
Next k
wb.SaveAs filename:=path & wksht.Range("A" & i).Value & ".xlsx"
wb.Close
Next i
End Sub
Try this:
Sub filename()
Dim i As Integer
For i = 1 To 32
ChDir "C:\path\"
ActiveWorkbook.SaveAs Filename:= _
"C:\path\" & Range("A" & i).Value & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Next i
End Sub
Note: Don't use "C:\" choose another folder. Probably you will need admin permissions to save there.
I'm exporting filtered results from my subform to Excel, and naming Excel file as I want. Here's my code :
Sub XcelExport()
Dim Results As Recordset
Dim RecCount As Integer
Dim XcelFileName As String
Dim FilePath As String
Dim wb As Excel.Workbook
Dim XcelFile As Excel.Application
'Set name of file with date
XcelFileName = "MySubform_Results_" & Format(Date, "dd/mm/yyyy") & ".xlsx"
' Set destinaton folder of saved file
FilePath = CurrentProject.Path & "\" & XcelFileName
Set XcelFile = New Excel.Application
Set wb = XcelFile.Workbooks.Add
'Fetch subform record source
Set Results = Forms![MainForm]![MySubform].Form.RecordsetClone
With wb
XcelFile.ScreenUpdating = False
' Add field names to workbook
For RecCount = 0 To Results.Fields.Count - 1
XcelFile.Cells(1, RecCount + 1).Value = Results.Fields(RecCount).Name
Next RecCount
' Copy subform results to Excel file
XcelFile.Range("A2").CopyFromRecordset Results
.SaveAs Filename:=FilePath, FileFormat:=51
XcelFile.ScreenUpdating = True
.Close
End With
Set XcelFile = Nothing
Set Results = Nothing
End Sub
Code works, with one flaw. When I run it again, it creates a new file again, but .RecordsetClone is gone, so values from Subform are not exported again. Beside that, I find it very strange that code works, just take a look at »with wb« statement – I had to reference to XcelFile on certain commands or they didn't work, regardless I allready set wb to XcelFile in code above (Set wb = XcelFile.Workbooks.Add). What Is wrong in my code, does anybody have a better solution ???
So this is final code, I hope It will be useful to someone else too.
Sub XcelExport()
Dim Results As Recordset
Dim RecCount As Integer
Dim XcelFileName As String
Dim FilePath As String
Dim wb As Excel.Workbook
Dim XcelFile As Excel.Application
'Set name of file with date
XcelFileName = "MySubform_Results_" & Format(Date, "dd/mm/yyyy") & ".xlsx"
' Set destinaton folder of saved file
FilePath = CurrentProject.Path & "\" & XcelFileName
Set XcelFile = New Excel.Application
Set wb = XcelFile.Workbooks.Add
'Fetch subform record source
Set Results = Forms![MainForm]![MySubform].Form.RecordsetClone
With wb
XcelFile.ScreenUpdating = False
' Add field names to workbook
For RecCount = 0 To Results.Fields.Count - 1
XcelFile.Cells(1, RecCount + 1).Value = Results.Fields(RecCount).Name
Next RecCount
' Copy subform results to Excel file and set Results to first row
Results.Movefirst
XcelFile.Range("A2").CopyFromRecordset Results
.SaveAs Filename:=FilePath, FileFormat:=51
XcelFile.ScreenUpdating = True
.Close
End With
Set XcelFile = Nothing
Set Results = Nothing
End Sub