I have a problem with data import. I am using the following code to import data from another CSV.
Sub Import(ByVal sFileName As String)
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range
Set wb1 = ActiveWorkbook
Set PasteStart = [DATA!A1]
'Clean Data Sheet
Sheets("DATA").Select
Cells.Select
Selection.ClearContents
If IsEmpty(sFileName) Then
MsgBox "No File Specified.", vbExclamation, "ERROR"
Exit Sub
Else
Set wb2 = Workbooks.Open(Filename:=sFileName, Delimiter:=";")
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
'Text to Column if needed
Call TextToColumnSemiToComa
'Activate Home Sheet
Worksheets("Netherland DCA").Activate
'Complete message
MsgBox ("Data Import Complete")
End Sub
The problem is that the macro changes dates. For ex. the original file has 12/10/2019(dd/mm/yyyy), but after import its 10/12/2019(dd/mm/yyyy). Do you know where could be problem?
Related
Is there a way to save the active/selected worksheet without having to specify sheets(1)?
The code below is execute via command button and will take the worksheet "Quote" copy to a new workbook, and then prompt to save under the downloads directory.
I'm also trying to get that button to save whichever sheet is selected, it could be Quote or Sheet1, but not both.
Private Sub CommandButton4_Click() ' save worksheet
'Gets the name of the currently visible worksheet
Filename = ActiveSheet.Name
'Puts the worksheet into its own workbook
ThisWorkbook.ActiveSheet.Copy
'Saves the workbook - uses the name of the worksheet as the name of the new workbook
'Filename = Range("A1")
'ActiveWorkbook.Save
Dim NameFile As Variant
With Worksheets("Quote")
'NameFile = .Range("A1") & "_" & .Range("B5") & "_" & ".xls"
End With
NameFile = Application.GetSaveAsFilename(InitialFileName:=Environ("USERPROFILE") & "\Downloads\" & NameFile, Filefilter:="Fichier Excel (*.xls), *.xls")
If NameFile = False Then
MsgBox "File not saved"
Else
ActiveWorkbook.SaveAs Filename:=NameFile
End If
'Closes the newly created workbook so you are still looking at the original workbook
ActiveWorkbook.Close
End Sub
This Sub creates a new Workbook from a sheet. But you must have a way to call this Sub of every sheet, or a better place is a button in the ribbon witch in it's handler: Call NewBookOfSheet(ActiveSheet).
Public Sub NewBookOfSheet(ws As Worksheet)
Dim nwb As Workbook, curwb As Workbook
If ws Is Nothing Then Exit Sub
Set curwb = ws.Parent
Set nwb = Workbooks.Add
curwb.Activate
ws.Select
ws.Copy Before:=nwb.Sheets(1)
nwb.Activate
Application.Dialogs(xlDialogSaveAs).Show ws.Name
End Sub
Copy the Active Worksheet to a New Workbook
Private Sub CommandButton4_Click() ' save worksheet
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim sws As Worksheet: Set sws = ActiveSheet
sws.Copy
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
Dim dws As Worksheet: Set dws = dwb.Sheets(1) ' the one and only
Dim dwbName: dwbName = Application.GetSaveAsFilename( _
InitialFileName:=Environ("USERPROFILE") & "\Downloads\" & dws.Name, _
FileFilter:="Fichier Excel (*.xls), *.xls")
If dwbName = False Then
MsgBox "File not saved", vbCritical
Else
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs Filename:=dwbName, FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True
End If
dwb.Close SaveChanges:=False
' Now 'dws' and 'dwb' are invalid but still 'Not Nothing'.
' On the other hand, 'sws' still points to the (initial) source worksheet.
' If you need to reference the source workbook use:
'Dim swb As Workbook: Set swb = sws.Parent
End Sub
My code here is working fine when it opens a file and copies it to my current worksheet but I am unable to copy the data as values only. Can someone take a look?
Sub ImportData()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range
Set wb1 = ActiveWorkbook
Set PasteStart = [RawData!A1]
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a Report to Parse", _
FileFilter:="Report Files *.xls (*.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
End Sub
please advise how to edit the below code be get the File picker dialog works in the below code:
Sub Update_Riyadh_Store()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range
Dim fd As Office.FileDialog
Set wb1 = ActiveWorkbook
Set PasteStart = Sheets("Riyadh Stock").Range("A1")
Application.ScreenUpdating = False
'sheets and range to be updated'
Sheets("Riyadh Stock").Select
Range("A1:F2500").Select
Selection.ClearContents
Sheets("Riyadh Stock").Range("A31").Select
ٍSet FileToOpen = Application.FileDialog(msoFileDialogFilePicker)
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
Application.ScreenUpdating = True
End If
wb2.Close
MsgBox "Stock has been updated successfully.", vbOKOnly, "Updated Successfully"
End Sub
Please advise what is missing to make this code works.
I am new to VBA. And below is my code.What i am trying to do is copy data from one worksheet and paste it in another worksheet. The only problem with my code is that every time i try to copy a new file it overwrites the previous data . What i want is to paste data in new line.
Private Sub CommandButton1_Click()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range
Dim erow
Set wb1 = ActiveWorkbook
Set PasteStart = [Dominoes_Excel!A1]
FileToOpen = Application.GetOpenFilename
If FileToOpen = False Then
MsgBox ("No File Specified.")
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
The next line down is given by
Set PasteStart = PasteStart.Offset(1,0) '1 row down, no columns
The next blank line in a sheet (which I suspect is what you want) is given by
set pastestart = worksheets("Dominoes_Excel").cells(worksheets("Dominoes_Excel").rows.count,1).end(xlup).offset(1,0)
I did code to save excel range to csv
but its getting hidden columns also can somebody help to remove hidden column?
'Sub to select range from excel and save it as CSV
'Added code for paste special
Private Sub Main()
Dim sFullFilePath As String
Dim selectedRange As Range
sFullFilePath = "C:\MyFileName.csv"
Set selectedRange = Application.InputBox("Select a range", "Get Range", Type:=8)
RangeTOCsv sFullFilePath, selectedRange
End Sub
Private Sub RangeTOCsv(sFullFilePath As String, selectedRange As Range)
Dim workBook As workBook
Application.DisplayAlerts = False
selectedRange.Copy
Set workBook = Workbooks.Add
With workBook
.Sheets(1).Select
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
.SaveAs sFullFilePath, xlCSV
.Close
End With
End Sub
You need to modify RangeToCsv procedure like below:
Private Sub RangeToCsv(sFullFilePath As String, selectedRange As Range)
Dim rng As Excel.Range
Dim Workbook As Workbook
Application.DisplayAlerts = False
Set rng = selectedRange.SpecialCells(xlCellTypeVisible)
Set Workbook = Workbooks.Add
With Workbook
Call rng.Copy
.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
.SaveAs sFullFilePath, xlCSV
.Close
End With
End Sub
Before the selected range is pasted into new workbook, it is being filtered by function SpecialCells with parameter Type set to xlCellTypeVisible.
After this operation, variable rng stores all the visible cells from the original selectedRange range.