I'm writing a script that copies from cells to test file (.sql)
Everytime I create a new file the resulte is in doublequotes, and it's unacceptable, because it has to be an SQL script and with quotes it wouldn't work.
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim saveFile As String
Dim WorkRng As Range
Sheets("TU").Columns(10).Copy
Sheets("TU").Columns(11).PasteSpecial xlPasteValues
On Error Resume Next
Set WorkRng = Range("K3:K20")
Set wb = Application.Workbooks.Add
WorkRng.Copy
wb.Worksheets(1).Paste
saveFile = Application.GetSaveAsFilename(fileFilter:="Text Files (*.sql), *.sql")
wb.SaveAs Filename:=saveFile, FileFormat:=xlTextWindows, CreateBackup:=False
wb.Close
End Sub
Any ideas?
Checked this and this doesn't show as in single quotes for me. Do the original values of each cell contain single quotes?
If that is the case then you can try a Loop on the cells and replace each quote after you paste the values into column K.
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim saveFile As String
Dim WorkRng As Range
Dim cell As Range, rng As Range
Set rng = Range("K:K")
Sheets("TU").Columns(10).Copy
Sheets("TU").Columns(11).PasteSpecial xlPasteValues
For Each cell In rng
If cell.Value = "" Then
Exit For
End If
If InStr(1, cell.Value, "'") > 0 Then
cell.Value = Replace(cell.Value, "'", "")
End If
Next cell
On Error Resume Next
Set WorkRng = Range("K3:K20")
Set wb = Application.Workbooks.Add
WorkRng.Copy
wb.Worksheets(1).Paste
saveFile = Application.GetSaveAsFilename(fileFilter:="Text Files (*.sql), *.sql")
wb.SaveAs Filename:=saveFile, FileFormat:=xlTextWindows, CreateBackup:=False
wb.Close
End Sub
Related
I'm trying to run this code in excel from another application.The code runs without problems, however rngNumber.Copy wsData.Range("A2") isn't copied. I've tested the same code directly in excel and it was copied perfectly. I think that maybe rngNumber isn't set properly when the code is runned from another application. But, I don't get exactly the reason. Any suggestion would be appreciate, thanks.
Sub TEST()
' Try to connect to a running instance of Excel.
Dim excelApp As Excel.Application
On Error Resume Next
Set excelApp = GetObject(, "Excel.Application")
If Err Then
Err.Clear
' Couldn't connect so start Excel. It's started invisibly.
Set excelApp = CreateObject("Excel.Application")
If Err Then
MsgBox "Cannot access excel."
Exit Sub
End If
End If
' You can make it visible if you want. This is especially
' helpful when debugging.
excelApp.Visible = True
'Open the excel file (through dialog)
Dim ExcelFilePath As Variant
ExcelFilePath = excelApp.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If ExcelFilePath <> False Then
Set wb = excelApp.Workbooks.Open(ExcelFilePath)
End If
' Open the excel file
Dim wb as Workbook
Set wb = excelApp.ActiveWorkbook
Dim ws as Worksheet
Set ws = wb.Worksheets(1)
ws.Activate
'Set Worksheet
Dim wsData As WorkSheet
Set wsData = wb.Worksheets(2)
'Write column titles
With wsData
.Cells(1, "A").Value = "Number"
End With
'Get column letter for each column whose first row starts with an specific string
ws.Activate
Dim sNumber as String
sNumber= Find_Column("Number")
'Define variables
Dim rngNumber As Range
' Copy and paste data from "Number" column to Column "A" in Worksheets "Data"
ws.Activate
'Find which is the last row with data in "Number" column and set range
With ws.Columns(sNumber)
Set rngNumber = Range(.Cells(2), .Cells(.Rows.Count).End(xlUp))
End With
'Copy and paste data from "Number" column
rngNumber.Copy wsData.Range("A2")
End Sub
Private Function Find_Column(Name As String) As String
Dim rngName As Range
Dim Column As String
With ws.Rows(1)
On Error Resume Next
Set rngName = .Find(Name, .Cells(.Cells.Count), xlValues, xlWhole)
' Calculate Name Column Letter.
Find_Column = Split(rngName.Address, "$")(1)
End With
End Function
Explicitly define the excel object and remove the On Error Resume Next. This works from Word.
Option Explicit
Sub TEST()
' Try to connect to a running instance of Excel.
Dim excelApp As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.WorkSheet, wsData As Excel.WorkSheet
Dim rngNumber As Excel.Range
On Error Resume Next
Set excelApp = GetObject(, "Excel.Application")
If Err Then
Err.Clear
' Couldn't connect so start Excel. It's started invisibly.
Set excelApp = CreateObject("Excel.Application")
If Err Then
MsgBox "Cannot access excel."
Exit Sub
End If
End If
On Error GoTo 0
' You can make it visible if you want. This is especially
' helpful when debugging.
excelApp.Visible = True
excelApp.WindowState = xlMinimized
'Open the excel file (through dialog)
Dim ExcelFilePath As Variant
ExcelFilePath = excelApp.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If ExcelFilePath = False Then
MsgBox "No file not selected"
Exit Sub
End If
Set wb = excelApp.Workbooks.Open(ExcelFilePath)
Set ws = wb.Sheets(1)
Set wsData = wb.Sheets(2)
' Get column letter for each column whose first row
' starts with an specific string
Dim sNumber As String, LastRow As Long
sNumber = Find_Column(ws, "Number")
If sNumber = "#N/A" Then
MsgBox "Column 'Number' not found in " & vbLf & _
"Wb " & wb.Name & " Sht " & ws.Name, vbExclamation
Exit Sub
End If
' Copy and paste data from "Number" column to Column "A" in Worksheets "Data"
' Find which is the last row with data in "Number" column and set range
With ws
LastRow = .Cells(.Rows.Count, sNumber).End(xlUp).Row
Set rngNumber = .Cells(1, sNumber).Resize(LastRow)
End With
'Copy and paste data from "Number" column
rngNumber.Copy wsData.Range("A1")
excelApp.WindowState = xlMinimized
MsgBox LastRow & " rows copied from column " & sNumber, vbInformation
End Sub
Private Function Find_Column(ws, Name As String) As String
Dim rngName As Excel.Range
With ws.Rows(1)
Set rngName = .Find(Name, After:=.Cells(.Cells.Count), _
LookIn:=xlValues, lookat:=xlWhole)
End With
If rngName Is Nothing Then
Find_Column = "#N/A"
Else ' Calculate Name Column Letter.
Find_Column = Split(rngName.Address, "$")(1)
End If
End Function
I have this code where,
Worksheet: "Main" B3: what I am searching for in the file.
worksheet "AX": where to search.
I want to search in another opened workbook beginning with the letters: ECL_
Sub FindandKopy()
Dim CellContents As String
Dim rng As Range
Dim loDeinWert As String
Dim sfirstaddress As String
loDeinWert = Worksheets("main").Range("B3").Value
Set rng = Worksheets("AX").Range("B:B").Find(loDeinWert)
If rng Is Nothing Then
MsgBox "Data " & loDeinWert & " not found!"
Else
sfirstaddress = rng.Address
Do
rng.EntireRow.Copy
Worksheets("Main").Cells(Rows.Count, "A").End(xlUp) _
.Offset(6, 0).PasteSpecial Paste:=xlPasteAll
Set rng = Worksheets("AX").Range("B:B").FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> sfirstaddress
End If
End Sub
If you need to find a workbook that is already opened you could loop through all workbooks and check each workbooks name:
Dim ECLWb As Workbook
Dim wb As Workbook
For Each wb in Application.Workbooks
If wb.Name Like "ECL_*" Then
Set ECLWb = wb
Exit For
End If
Next wb
If ECLWb Is Nothing Then
MsgBox "ECL_* not found."
Exit Sub
Else
'use that workbook like
ECLWb.Worksheets("AX")…
End If
Looking to use filter in workbook B, with clipboard content from workbook A. Workbook B name is a wildcard and macro needs to be run from workbook A. So far I have:
Sub SwitchAndFilter()
'
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Name Like "*ABC_*" Then wb.Activate:
With ActiveWorkbook
'code here just getting run onto workbook A, plus don't know how to pass clipboard contents to a filter
ActiveSheet.Range("$A$1:$W$501").AutoFilter Field:=3, Criteria1:="12345" ' this should be clipboard contents from Workbook A
End With
Exit Sub
Next wb
'if code gets here, it isn't already open...
End Sub
UPDATE 1 Getting "Run-time error '9': Subscript out of range" on line:
.Sheets("Sheet1").Range("AA1").Paste
per advice below "should get the filter criteria from the range, not the clipboard" with that code I'm trying first to paste clipboard into range on wbB, and then refer to that range to filter. Full code I have now is:
Sub SwitchAndFilter3()
Dim wbA As ThisWorkbook
Dim wbB As Workbook
Set wbA = ThisWorkbook
For Each wbB In Application.Workbooks
If wbB.Name Like "*ABC_*" And wbA.Name <> wbB.Name Then
'Your with should reference the context of your for, i.e. wbB, not ActiveWorkbook.
With wbB
'You should really try to avoid Activesheet
'Also, you should get the filter criteria from the range, not the clipboard.
'
.Sheets("Sheet1").Range("AA1").Paste
.ScrollColumn = 2
'
.Sheets("Sheet1").Range("$A$1:$W$501").AutoFilter Field:=3, Criteria1:=wbB.Sheets("Sheet1").Range("AA1").Value
'If you need wbB to be active:
.Activate
End With
Exit Sub
End If
Next wbB
COPY SUB FOR #ValonMiller 9.26.18 In response to request in comment below
Sub CopyFirstOne()
Dim position As Integer
Dim substring As String
position = InStr(ActiveCell, " ")
If (position > 0) Then
substring = Left(ActiveCell, position - 1)
Dim MyText As DataObject
Set MyText = New DataObject
On Error Resume Next
MyText.setText substring
MyText.PutInClipboard
End If
'below macro works on it's own, but Calling from here crashes XL for a bit and gives error on PasteSpecial
'Call SwitchAndFilterWorks
End Sub
10.8.18 Update
Sub ListFiles_A3_Works()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Application.Goto Reference:="Body"
Selection.ClearContents
Range("B6").Select
objFolderName = Range("A3").Value
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(objFolderName)
'Set objFolder = objFSO.GetFolder(Range("A3").Value)
i = 5
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 1) = objFile.Name
'print file path
'Cells(i + 1, 2) = objFile.Path
i = i + 1
Next objFile
Range("B6").Select
Range("A6").Select
ActiveWindow.ScrollRow = Selection.Row
Call CopyFirstOne
End Sub
[Updated 9/26 based on discussion above]
Make sure you update the line With wbB.Sheets("Sheet1") with the correct sheet name.
Sub CopyFirstOne()
Dim position As Integer
Dim substring As String
position = InStr(ActiveCell, " ")
If (position > 0) Then
substring = Left(ActiveCell, position - 1)
Else
substring = ActiveCell.Value
End If
'Pass the filter string directly
Call SwitchAndFilter(substring)
End Sub
Sub SwitchAndFilter(fitlerValue As String)
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Name Like "*ABC_*" And ThisWorkbook.Name <> wb.Name Then
'Changed with to target Sheet, instead of Workbook
With wb.Sheets("Sheet1")
.Range("$A$1:$W$501").AutoFilter Field:=3, Criteria1:=fitlerValue
'Optional
.Activate
End With
Exit Sub
End If
Next wb
'if code gets here, it isn't already open...
End Sub
I don't think this is the best solution, but to address what I believe to be the root cause of your copy/paste issue, try this:
Sub CopyFirstOne()
Dim position As Integer
Dim substring As String
Dim MyText As DataObject
Set MyText = New DataObject
position = InStr(ActiveCell, " ")
If (position > 0) Then
substring = Left(ActiveCell, position - 1)
Else
substring = ActiveCell.Value
End If
On Error Resume Next
MyText.setText substring
MyText.PutInClipboard
Call SwitchAndFilterWorks
End Sub
Sub CopyData()
Dim wb As Workbook
Dim wsDest As Worksheet
Dim sFilePath As String
Dim aData As Variant
sFilePath = Application.GetOpenFilename("CSV Files, *.csv", MultiSelect:=False)
If sFilePath = "False" Then Exit Sub 'Pressed cancel
Set wb = ActiveWorkbook
Set wsDest = wb.Sheets("Sheet2")
Application.ScreenUpdating = False
With Workbooks.Open(sFilePath)
aData = .Sheets(1).Range("A1", .Sheets(1).Cells(.Sheets(1).Rows.Count, "F").End(xlUp)).Value
.Close False
End With
Application.ScreenUpdating = True
With wsDest.Range("B11").Resize(UBound(aData, 1), UBound(aData, 2))
.Value = aData
.Resize(, 1).NumberFormat = "mm/dd/yyyy" 'Can set date format here, change to dd/mm/yyyy if needed
End With
End Sub
Above is a sample code to copy data from one workbook to another.
I want to be able to copy specific cells on specific rows that comply with an IF operator, and for that I want to be able to iterate through each row of the CSV file that is being opened to apply the logical operators.
How can the above code be modified to achieve that?
I'm not very good with VBA.
The simple and "standard" way is to apply an AutoFilter on the source and copy the visible range.
Sub CopyData()
Dim wsDest As Worksheet: Set wsDest = ThisWorkbook.Sheets("Sheet2")
Dim sFilePath As String: sFilePath = Application.GetOpenFilename("CSV Files, *.csv", MultiSelect:=False)
If sFilePath = "False" Then Exit Sub 'Pressed cancel
Application.ScreenUpdating = False
On Error GoTo Cleanup
With Workbooks.Open(sFilePath).Sheets(1)
With .Range("A1", .Cells(.Rows.Count, "F").End(xlUp))
.AutoFilter 1, ">" & CDate("1/1/2017") ' <-- Captures dates since year 2017 for example
.SpecialCells(xlCellTypeVisible).Copy
End With
wsDest.Range("B11").PasteSpecial
wsDest.Columns("B").NumberFormat = "mm/dd/yyyy"
.Parent.Close False
End With
Cleanup:
Application.ScreenUpdating = True
End Sub
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.