tomkane
06-30-2011, 06:33 AM
i am new to the forum so i hope i have posted this in the correct place. i am also a bit for a novice when it comes to vba.
i am trying to copy a range from multiple csv files into a new workbook. i have been trying to amend a vba program that does something similar without much luck.
here is what i have been working on. this currently returns the address of the data that i require but with error messages. this has worked fine for excel files but not the csv files.
also, this is a very slow method and i know there must be a much better/quicker way to copy and paste the whole range from each csv file and not go row by row...
Sub Summary_cells_from_Different_Workbooks_1()
Dim CSVFileNames As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim shName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String
Set Rng = Range("C4:C6261") '<---- Change
'Select the files with GetOpenFilename
CSVFileNames = Application.GetOpenFilename _
(filefilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)
If IsArray(CSVFileNames) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)
'The links to the first workbook will start in row 2
RwNum = 1
For FNum = LBound(CSVFileNames) To UBound(CSVFileNames)
RwNum = 1
ColNum = 1 + ColNum
FinalSlash = InStrRev(CSVFileNames(FNum), "\")
JustFileName = Mid(CSVFileNames(FNum), FinalSlash + 1)
JustFolder = Left(CSVFileNames(FNum), FinalSlash - 1)
shName = Mid(CSVFileNames(FNum), 131, 6)
'copy the workbook name in column A
SummWks.Cells(1, ColNum).Value = JustFileName
'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & shName & "'!"
For Each myCell In Rng.Cells
'ColNum = ColNum + 1
RwNum = RwNum + 1
SummWks.Cells(RwNum, ColNum).Value = "=" & PathStr & myCell.Address
'SummWks.Cells(RwNum, ColNum).Paste.Value
Next myCell
On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet not exist in the workbook the colum color will be Yellow.
SummWks.Cells(, RwNum).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
'ColNum = ColNum + 1
RwNum = RwNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum
' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
MsgBox "The Summary is ready, save the file if you want to keep it"
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub
i am trying to copy a range from multiple csv files into a new workbook. i have been trying to amend a vba program that does something similar without much luck.
here is what i have been working on. this currently returns the address of the data that i require but with error messages. this has worked fine for excel files but not the csv files.
also, this is a very slow method and i know there must be a much better/quicker way to copy and paste the whole range from each csv file and not go row by row...
Sub Summary_cells_from_Different_Workbooks_1()
Dim CSVFileNames As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim shName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String
Set Rng = Range("C4:C6261") '<---- Change
'Select the files with GetOpenFilename
CSVFileNames = Application.GetOpenFilename _
(filefilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)
If IsArray(CSVFileNames) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)
'The links to the first workbook will start in row 2
RwNum = 1
For FNum = LBound(CSVFileNames) To UBound(CSVFileNames)
RwNum = 1
ColNum = 1 + ColNum
FinalSlash = InStrRev(CSVFileNames(FNum), "\")
JustFileName = Mid(CSVFileNames(FNum), FinalSlash + 1)
JustFolder = Left(CSVFileNames(FNum), FinalSlash - 1)
shName = Mid(CSVFileNames(FNum), 131, 6)
'copy the workbook name in column A
SummWks.Cells(1, ColNum).Value = JustFileName
'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & shName & "'!"
For Each myCell In Rng.Cells
'ColNum = ColNum + 1
RwNum = RwNum + 1
SummWks.Cells(RwNum, ColNum).Value = "=" & PathStr & myCell.Address
'SummWks.Cells(RwNum, ColNum).Paste.Value
Next myCell
On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet not exist in the workbook the colum color will be Yellow.
SummWks.Cells(, RwNum).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
'ColNum = ColNum + 1
RwNum = RwNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum
' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
MsgBox "The Summary is ready, save the file if you want to keep it"
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub