I am a newcomer to VBA. I am trying to copy selected range from different workbooks and pasted to a target workbook with different sheetname correspondingly to the name of source file.
The code as below:
'open file
Sub RstChk()
Dim StrFileName As String
Dim StrFilePath As String
Dim TimeStr As String
Dim Version As Integer
Dim x As Workbook
Dim y As Workbook
Dim PstTgt As String
'define filename as array
Dim FN(10) As String
FN(1) = "CIO Wholesale"
FN(2) = "RMG"
FN(3) = "DCM"
FN(4) = "DivHeadOth"
FN(5) = "Runoff"
FN(6) = "Other Risk Subs"
FN(7) = "FIC"
FN(8) = "Treasury"
FN(9) = "Cash Equities"
FN(10) = "Global Derivatives"
'define file path
StrFilePath = "V:\RISKMIS\PUBLIC\apps\MORNING\RMU 1.5 Report\Consolidated\"
'define TimeStr
TimeStr = Format(Now() - 1, "mm-dd-yyyy")
Set y = Workbooks.Open("H:\Eform\Report_checking.xls")
'applying filename from array using loop
'----------------------------------------------------------------
For i = 1 To 10
'define changing file name with path & loop
For Version = 65 To 68
StrFileName = (StrFilePath & FN(i) & "_" & TimeStr & "_" & Chr(Version) & ".xls")
Set x = Workbooks.Open(StrFileName)
'-------------------------------------------------
If Chr(Version) = "A" Then
PstTgt = "A3"
ElseIf Chr(Version) = "B" Then
PstTgt = "E3"
ElseIf Chr(Version) = "C" Then
PstTgt = "I3"
Else
PstTgt = "M3"
End If
'copy the column and paste to report checking
y.Worksheets(FN(i)).PstTgt.Copy Destination = x.Sheets("Risk Summary").Range ("AA5:AC118")
Application.CutCopyMode = False
x.Close
Next Version
Next i
End Sub
I get error when I try to copy the range from source file (x) to target file (Y).
Run-time error '13', type mismatch
Just can't figure out what went wrong.
Thanks very much for your help.
Dan
You got this error because your variable PstTgt is a string and not a range "type mismatch"
If you look at the documentation of Range.Copy https://msdn.microsoft.com/en-us/library/office/ff837760.aspx
You have two choices :
Make PstTgt a range and referencing directly to the range in your endif
' Redefine PstTgt as a range
dim PstTgt as Range
' set value of PstTgt
If Chr(Version) = "A" Then
set PstTgt = y.Worksheets(FN(i)).Range("A3")
endif
...
' Copy the range where you want
PstTgt.Copy destination:=x.Sheets("Risk Summary").Range("AA5")
You keep your code like that and just correct your copy by adding Range
y.Worksheets(FN(i)).Range(PstTgt).Copy Destination = x.Sheets("Risk Summary").Range("AA5")
Related
I have a Word doc with some numbers referred in the foot notes. and I am exporting these references as a csv file.
Sub FindNumber()
Dim exp, exp1 As RegExp
Set exp = New RegExp
exp.Pattern = "\b[A-Za-z]{3}[0-9]{7}\b"
exp.Global = True
Dim splits(1000) As String
Dim x As Long
Dim results As MatchCollection
Set results = exp.Execute(ActiveDocument.StoryRanges(wdFootnotesStory))
x = 1
For Each res In results
splits(x) = res
x = x + 1
Next res
Dim Filename As String, line As String
Dim i As Integer
Filename = "C:\VBA Export" & "\Numbers.csv"
Open Filename For Output As #2
Print #2, "Control Numbers"
For i = LBound(splits) To UBound(splits)
Print #2, splits(i)
Next i
Close #2
MsgBox "Numbers were exported to " & Filename, vbInformation
End Sub
The code above was working fine and just suddenly starting throwing error at 'splits(x) = res'
I have tried checking my regex and I can see that it works fine. If I change splits(x) to splits(6) or something similar it works like a charm .
Can someone please help ?
EDIT - changed code to write matches directly to Excel.
Sub Tester()
Dim oXl As Excel.Application 'add reference to MS Excel object library...
Dim oWb As Excel.Workbook, c As Excel.Range, i As Long, col As Collection
Set oXl = New Excel.Application
oXl.Visible = True
Set oWb = oXl.Workbooks.Add()
Set c = oWb.Worksheets(1).Range("A1")
ListMatchesInExcel ActiveDocument.StoryRanges(wdFootnotesStory), _
"\b[A-Za-z]{3}[0-9]{7}\b", _
"Id Numbers", c
Set c = c.Offset(0, 1)
ListMatchesInExcel ActiveDocument.StoryRanges(wdFootnotesStory), _
"\b[A-Za-z]{2}[0-9]{9}\b", _
"Other Numbers", c
Set c = c.Offset(0, 1)
'etc etc
End Sub
'Search through `SearchText` for text matching `patt` and export all
' matches to Excel with a header `HeaderText`, starting at range `c`
Sub ListMatchesInExcel(SearchText As String, patt As String, _
headerText As String, c As Excel.Range)
'add reference to MicroSoft VBscript regular expressions
Dim exp, exp1 As RegExp, col As New Collection
Dim results As MatchCollection, res As Match, i As Long
Set exp = New RegExp
exp.Pattern = patt
exp.Global = True
Set results = exp.Execute(SearchText)
'log to Immediate pane
Debug.Print (col.Count - 1) & " matche(s) for '" & patt & "'"
c.Value = headerText
i = 1
For Each res In results
c.Offset(i).Value = res
i = i + 1
Next res
c.EntireColumn.AutoFit
End Sub
I'm just new in using excel vba macro. I am trying to create text file and use the cell values as name of individual text file. At the first place the value contains character and those character will be replaced. the only value will remain are all numbers. That function is working well. My problem is once I execute the create button, the program will create an extra text file which name is base on empty cell and no any input "D" as input in the text file. What I want is to create a text file without that extra text file created. below is my excel format and the code.
I have 3 column use as below:
LOG DATA INPUT BLOCK NAME
5687 D ASD
5689 D
5690 D
5692 D
5691 D
5688 D
4635 D
Correct result will create four text file:
abc-5687.req
abc-5689.req
abc-5690.req
abc-5692.req
Result with extra text file consider as wrong see below:
abc-.req <-- extra text file created
abc-5687.req
abc-5689.req
abc-5690.req
abc-5692.req
my code:
Private Sub CREATE_REQ_Click()
Dim myDataSheet As Worksheet
Dim myReplaceSheet As Worksheet
Dim myLastRow As Long
Dim myRow As Long
Dim myFind As String
Dim myReplace1 As String
Dim myReplace2 As String
Dim sExportFolder, sFN
Dim rArticleName As Range
Dim rDisclaimer As Range
Dim oSh As Worksheet
Dim oFS As Object
Dim oTxt As Object
' Specify name of Data sheet
Set myDataSheet = Sheets("Sheet1")
' Specify name of Sheet with list of replacements
Set myReplaceSheet = Sheets("Sheet2")
' Assuming list of replacement start in column A on row 2, find last entry in list
myLastRow = myReplaceSheet.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
' Loop through all list of replacments
For myRow = 2 To myLastRow
' Get find and replace values (from columns A and B)
myFind = myReplaceSheet.Cells(myRow, "A")
myReplace1 = myReplaceSheet.Cells(myRow, "B")
' Start at top of data sheet and do replacements
myDataSheet.Activate
Range("A2").Select
' Ignore errors that result from finding no matches
On Error Resume Next
' Do all replacements on column A of data sheet
Columns("A:A").Replace What:=myFind, Replacement:=myReplace1, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next myRow
sExportFolder = "D:\TEST\REQ_FILES_CREATED_HERE"
Set oSh = Sheet1
Set oFS = CreateObject("Scripting.Filesystemobject")
For Each rArticleName In oSh.UsedRange.Columns("A").Cells
Set rDisclaimer = rArticleName.Offset(, 1)
If rArticleName = "" & "LOG DATA" Then
oTxt = False
Else
'Add .txt to the article name as a file name
sFN = "-" & rArticleName.Value & ".req"
Set oTxt = oFS.OpenTextFile(sExportFolder & "\" & ActiveSheet.Cells(2, 3) & sFN, 2, True)
oTxt.Write rDisclaimer.Value
oTxt.Close
End If
Next
'Reset error checking
On Error GoTo 0
Application.ScreenUpdating = True
MsgBox "Replacements complete! "
End Sub
For Each rArticleName In oSh.UsedRange.Columns("A").Cells
Set rDisclaimer = rArticleName.Offset(, 1)
If Not(rArticleName = "" Or rArticleName = "LOG DATA") Then
'Add .txt to the article name as a file name
sFN = "-" & rArticleName.Value & ".req"
Set oTxt = oFS.OpenTextFile(sExportFolder & "\" & ActiveSheet.Cells(2, 3) & sFN, 2, True)
oTxt.Write rDisclaimer.Value
oTxt.Close
End If
Next
Pretty close to a one line fix. You just need to fix the If. Once that's right you don't need the Else.
I would like to copy some cells from one file to several files. In order to do so,the macro will copy the range and open the several files in order to paste the values. I perform a loop in order to open each of the destination files (the begin of the name of each of the ouput file is the same but the extension differs from file to file : it is based on a range of cells called Name). The concatenation doesn't work well.
Thank you so much for your help!!
Sub update()
Application.ScreenUpdating = False
Dim wkbkorigin As Workbook
Dim wkbkdestination As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim i As Integer
Dim j As Integer
Dim nrow As Integer
Dim ncol As Integer
Dim Pathref As String
Dim Name As String
nrow = Range("names").Rows.Count
ncol = Range("Range").Columns.Count
'this is the path to the different files, the begin is the same but the extension will be added in the loop (the extentsion is based on the value in the range Name
Pathref = Range("Pathref").Value & "[yasmine_nouri]"
For i = 1 To nrow
Name = Range("Names").Cells(i, 1).Value
Set wkbkorigin = ActiveWorkbook
'here i set my destination file, the begin is the same but the extension is based on the value in the range Name : this concatenation doesn't work.
Set wkbkdestination = Workbooks.Open([& Pathref & Name & ".xlsb"])
Set originsheet = wkbkorigin.Worksheets("Completed_DS")
Set destsheet = wkbkdestination.Worksheets("sheet1")
originsheet.Range("D4:Q5").Copy
destsheet.Range("A1").PasteSpecial
wkbkdestination.Close SaveChanges:=True
Next i
End Sub
As follows up from comments, OP should change
Pathref = Range("Pathref").Value & "[yasmine_nouri]"
'...
Set wkbkdestination = Workbooks.Open([& Pathref & Name & ".xlsb"])
to
Pathref = Range("Pathref").Value & "yasmine_nouri"
'...
Set wkbkdestination = Workbooks.Open(Pathref & Name & ".xlsb")
I would like to loop through an Excel worksheet and to store the values based on a unique ID in a text file.
I am having trouble with the loop and I have done research on it with no luck and my current nested loop continually overflows. Instead of updating the corresponding cell when the control variable is modified, it continues to store the initial Index value for all 32767 iterations.
Please can someone explain why this is happening, and provide a way of correcting it?.
Sub SortLetr_Code()
'sort columns for Letr_Code files
Dim lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1
Application.ScreenUpdating = True
'Value of cell for example B1 starts out as X
Dim x As Integer
Dim y As Integer
x = 2
y = 2
'Cell References
Dim rwCounter As Range
Dim rwCorresponding As Range
Dim rwIndexValue As Range
Dim rwIndexEnd As Range
Dim rwIndexStore As Range
'Variables for files that will be created
Dim FilePath As String
Dim Filename As String
Dim Filetype As String
'Variables defined
FilePath = "C:\Users\Home\Desktop\SURLOAD\"
Filetype = ".dat"
'Use Cell method for Loop
rwIndex = Cells(x, "B").Value
Set rwCounter = Range("B" & x)
'Use Range method for string manipulation
Set rwCorresponding = Range("A" & x)
Set rwIndexValue = Range("B" & y)
Set rwIndexStore = Range("B" & x)
Set rwIndexEnd = Range("B:B").End(xlUp)
'Objects for creating the text files
Dim FileCreate As Object
Set FileCreate = CreateObject("Scripting.FileSystemObject")
'Object for updating the file during the loop
Dim FileWrite As Object
For Each rwIndexStore In rwIndexEnd.Cells
'Get Substring of cell value in BX for the file name
Do Until IsEmpty(rwCounter)
Filename = Mid$(rwIndexValue, 7, 5)
Set FileWrite = FileCreate.CreateTextFile(FilePath + Filename + Filetype)
'Create the file
FileWrite.Write (rwCorresponding & vbCrLf)
Do
'Add values to the textfile
x = x + 1
FileWrite.Write (rwCorresponding & vbCrLf)
Loop While rwCounter.Value Like rwIndexValue.Value
'Close this file
FileWrite.Close
y = x
Loop
Next rwIndexStore
End Sub
I don't see a place you are setting rwCounter inside the loop.
It looks like it would stay on range("B2") and x would just continue to increase until it hits an error, either at the limit of integer or long.
add Set rwCounter = Range("B" & x) somewhere inside your loop to increment it
This is the solution.
Sub GURMAIL_File()
'sort columns for Letr_Code files
Dim lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1
Application.ScreenUpdating = True
'Variables that store cell number
Dim Corresponding As Integer
Dim Index As Integer
Dim Counter As Integer
Corresponding = 2
Index = 2
Counter = 2
'Cell References
Dim rwIndexValue As Range
'Variables for files that will be created
Dim l_objFso As Object
Dim FilePath As String
Dim Total As String
Dim Filename As String
Dim Filetype As String
Dim FolderName As String
'Variables defined
FilePath = "C:\Users\Home\Desktop\SURLOAD\"
'Name of the folder to be created
FolderName = Mid$(ActiveWorkbook.Name, 9, 8) & "\"
'Folder path
Total = FilePath & FolderName
'File Extension
Filetype = ".dat"
'Object that creates the folder
Set l_objFso = CreateObject("Scripting.FileSystemObject")
'Objects for creating the text files
Dim FileCreate As Object
Set FileCreate = CreateObject("Scripting.FileSystemObject")
'Object for updating the file during the loop
Dim FileWrite As Object
'Get Substring of letter code in order to name the file. End this loop once ID field is null.
Do While Len(Range("A" & Corresponding)) > 0
'Create the directory if it does not exist
If Not l_objFso.FolderExists(Total) Then
l_objFso.CreateFolder (Total)
End If
'Refence to cell containing a letter code
Set rwIndexValue = Range("B" & Index)
'Substring of that letter code
Filename = Mid$(rwIndexValue, 7, 5)
'Create the file using the substring and store it in the proper location
Set FileWrite = FileCreate.CreateTextFile(Total + Filename + Filetype, True)
'For each letter code, find the corresponding values. End the loop once the last value for the letter code is stored.
Do While Range("B" & Index) Like Range("B" & Counter)
'Add each line to the text file.
FileWrite.WriteLine (Range("A" & Corresponding))
'Incrementer variables that allow you to exit the loop
'if you have reached the last value of the current letter code.
Corresponding = Corresponding + 1
Counter = Counter + 1
Loop
'Close the file you were writing to
FileWrite.Close
'Make sure that Index value is updated to the next letter code
Index = Counter
'In case Index value needs updating (safeguard to make sure that the new letter code is stored to index value).
Set rwIndexValue = Range("B" & Index)
Loop
End Sub
I have exhausted my search capabilities looking for a solution to this. Here is an outline of what I would like to do:
User opens macro-enabled Excel file
Immediate prompt displays for user to enter or select file path of desired workbooks. They will need to select two files, and the file names may not be consistent
After entering the file locations, the first worksheet from the first file selection will be copied to the first worksheet of the macro-enabled workbook, and the first worksheet of the second file selection will be copied to the second worksheet of the macro-enabled workbook.
I've come across some references to ADO, but I am really not familiar with that yet.
Edit: I have found a code to import data from a closed file. I will need to tweak the range to return the variable results.
Private Function GetValue(path, file, sheet, ref)
path = "C:\Users\crathbun\Desktop"
file = "test.xlsx"
sheet = "Sheet1"
ref = "A1:R30"
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Sub TestGetValue()
path = "C:\Users\crathbun\Desktop"
file = "test"
sheet = "Sheet1"
Application.ScreenUpdating = False
For r = 1 To 30
For C = 1 To 18
a = Cells(r, C).Address
Cells(r, C) = GetValue(path, file, sheet, a)
Next C
Next r
Application.ScreenUpdating = True
End Sub
Now, I need a command button or userform that will immediately prompt the user to define a file path, and import the data from that file.
I don't mind if the files are opened during process. I just didn't want the user to have to open the files individually. I just need them to be able to select or navigate to the desired files
Here is a basic code. This code asks user to select two files and then imports the relevant sheet into the current workbook. I have given two options. Take your pick :)
TRIED AND TESTED
OPTION 1 (Import the Sheets directly instead of copying into sheet1 and 2)
Option Explicit
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim Ret1, Ret2
Set wb1 = ActiveWorkbook
'~~> Get the first File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select first file")
If Ret1 = False Then Exit Sub
'~~> Get the 2nd File
Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select Second file")
If Ret2 = False Then Exit Sub
Set wb2 = Workbooks.Open(Ret1)
wb2.Sheets(1).Copy Before:=wb1.Sheets(1)
ActiveSheet.Name = "Blah Blah 1"
wb2.Close SaveChanges:=False
Set wb2 = Workbooks.Open(Ret2)
wb2.Sheets(1).Copy After:=wb1.Sheets(1)
ActiveSheet.Name = "Blah Blah 2"
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wb1 = Nothing
End Sub
OPTION 2 (Import the Sheets contents into sheet1 and 2)
Option Explicit
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim Ret1, Ret2
Set wb1 = ActiveWorkbook
'~~> Get the first File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select first file")
If Ret1 = False Then Exit Sub
'~~> Get the 2nd File
Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select Second file")
If Ret2 = False Then Exit Sub
Set wb2 = Workbooks.Open(Ret1)
wb2.Sheets(1).Cells.Copy wb1.Sheets(1).Cells
wb2.Close SaveChanges:=False
Set wb2 = Workbooks.Open(Ret2)
wb2.Sheets(1).Cells.Copy wb1.Sheets(2).Cells
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wb1 = Nothing
End Sub
The function below reads data from a closed Excel file and returns the result in an array. It loses formatting, formulas etc. You might want to call the isArrayEmpty function (at the bottom) in your main code to test that the function returned something.
Public Function getDataFromClosedExcelFile(parExcelFileName As String, parSheetName As String) As Variant
'see http://www.ozgrid.com/forum/showthread.php?t=19559
'returns an array (1 to nRows, 1 to nCols) which should be tested with isArrayEmpty in the calling function
Dim locConnection As New ADODB.Connection
Dim locRst As New ADODB.Recordset
Dim locConnectionString As String
Dim locQuery As String
Dim locCols As Variant
Dim locResult As Variant
Dim i As Long
Dim j As Long
On Error GoTo error_handler
locConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & parExcelFileName & ";" _
& "Extended Properties=""Excel 8.0;HDR=YES"";"
locQuery = "SELECT * FROM [" & parSheetName & "$]"
locConnection.Open ConnectionString:=locConnectionString
locRst.Open Source:=locQuery, ActiveConnection:=locConnection
If locRst.EOF Then 'Empty sheet or only one row
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''' FIX: an empty sheet returns "F1"
'''''' http://support.microsoft.com/kb/318373
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" Then Exit Function 'Empty sheet
ReDim locResult(1 To 1, 1 To locRst.Fields.Count) As Variant
For i = 1 To locRst.Fields.Count
locResult(1, i) = locRst.Fields(i - 1).Name
Next i
Else
locCols = locRst.GetRows
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''' FIX: an empty sheet returns "F1"
'''''' http://support.microsoft.com/kb/318373
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" And UBound(locCols, 2) = 0 And locCols(0, 0) = "" Then Exit Function 'Empty sheet
ReDim locResult(1 To UBound(locCols, 2) + 2, 1 To UBound(locCols, 1) + 1) As Variant
If locRst.Fields.Count <> UBound(locCols, 1) + 1 Then Exit Function 'Not supposed to happen
For j = 1 To UBound(locResult, 2)
locResult(1, j) = locRst.Fields(j - 1).Name
Next j
For i = 2 To UBound(locResult, 1)
For j = 1 To UBound(locResult, 2)
locResult(i, j) = locCols(j - 1, i - 2)
Next j
Next i
End If
locRst.Close
locConnection.Close
Set locRst = Nothing
Set locConnection = Nothing
getDataFromClosedExcelFile = locResult
Exit Function
error_handler:
'Wrong file name, sheet name, or other errors...
'Errors (#N/A, etc) on the sheet should be replaced by Null but should not raise an error
If locRst.State = ADODB.adStateOpen Then locRst.Close
If locConnection.State = ADODB.adStateOpen Then locConnection.Close
Set locRst = Nothing
Set locConnection = Nothing
End Function
Public Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
End Function
Sample use:
Sub test()
Dim data As Variant
data = getDataFromClosedExcelFile("myFile.xls", "Sheet1")
If Not isArrayEmpty(data) Then
'Copies content on active sheet
ActiveSheet.Cells(1,1).Resize(UBound(data,1), UBound(data,2)) = data
End If
End Sub