im trying to combine the excel files in the sharepoint folder by using vba, but it seems the path does not working and run time error: 52 keep on coming out due to error in the highlighted code.
Here is the code:
Option Explicit
Sub ConsolidateAllDepartment()
Dim wb As Workbook
Dim wsCopy As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim mylCol As Long
Dim Row1 As Long
Dim FileNum As Integer
Dim ActWb As Workbook
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Open workbook
Dim nwb As Workbook
Dim nsh As Worksheet
'Open workbook
Set nwb = Workbooks.Add
Set nsh = nwb.Sheets(1)
'Set ActWb = ActiveWorkbook
Set wsCopy = Workbooks("Template for incident closure.xlsm").Sheets("Master Listing (ALL)")
'Copy Table Header
wsCopy.Range("A1:AD1").Copy nsh.Range("A1")
Set nwb = ActiveWorkbook
Dim mylRow As Long
'find last row after clear data
mylRow = Cells(Rows.Count, 1).End(xlUp).Row
'setting input path
myPath = "https:\\workspace.maybank.com.my\sites\Etiqa-Risk\OSRM\ORO\Incident%20Pending%20Closure\by%20Entity-Department\"
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'ChDir myPath
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'find last row and last col in wb
wb.Activate
Row1 = Cells(Rows.Count, "A").End(xlUp).Row
'copy the range from A2 to last cell
Range("A2:AD" & Row1).Copy
'paste to main file
nwb.Activate
Range("A" & mylRow + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
mylRow = mylRow + Row1 - 1
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Columns("A").Delete
nwb.SaveAs "https://workspace.maybank.com.my/sites/Etiqa-Risk/OSRM/ORM/Incident%20Pending%20Closure/Consolidated%20Files/Consolidated" & Format(Now(), "ddmmyyyy") & ".xlsx"
nwb.Close False
MsgBox "Done"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last row
'OUTPUT : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last column
'OUTPUT : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function
Related
Been trying to figure out how to copy a cell from worksheet A and paste it down a column in Worksheet B until it matches the same amount of rows as an adjacent column. Take the following screenshot for example. How would I properly accomplish this in VBA? Been trying to figure this out for a while now. All I've been able to do is copy the cell and paste it adjacent to the last cell in the adjacent column instead of down the entire column. The worksheet I'm copying data from is pictured below.
Copy From SpreadSheet down below
Paste to SpreadSheet down below
Current Code
Sub pullSecEquipment()
Dim path As String
Dim ThisWB As String
Dim wbDest As Workbook
Dim shtDest As Worksheet
Dim shtPull As Worksheet
Dim Filename As String
Dim Wkb As Workbook
Dim CopyRng As Range, DestRng As Range
Dim lRow As Integer
Dim destLRow As Integer
Dim Lastrow As Long
Dim FirstRow As Long
Dim UpdateDate As String
ThisWB = ActiveWorkbook.Name
Dim selectedFolder
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
selectedFolder = .SelectedItems(1) & "\"
End With
path = selectedFolder
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = Workbooks("GPnewchapterTEST2.xlsm").Worksheets("START")
'clear content of destination table
shtDest.Rows("8:" & Rows.Count).ClearContents
Filename = Dir(path & "\*.xls*", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
'MsgBox Filename
'''''
'SEC
'''''
If InStr(Filename, "Equipment") <> 0 Then
Dim range1 As Range
Set range1 = Range("E:K")
'For Each Wkb In Application.Workbooks
'For Each shtDest In Wkb.Worksheets
'Set shtPull = Wkb.Sheets(1)
'If shtPull.Name Like "*-*" Then
'last row
destLRow = Wkb.Sheets(1).Cells.Find(what:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
'1st row
lRow = Wkb.Sheets(1).Cells.Find(what:="EQUIPMENT DESCRIPTION", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'STHours
Dim i As Integer
For i = lRow To destLRow
Set CopyRng = Wkb.Sheets(1).Range(Cells(i, 5).Address, Cells(i, 11).Address)
Set DestRng = shtDest.Range("O" & shtDest.Cells(Rows.Count, "O").End(xlUp).Row + 1)
CopyRng.Copy
DestRng.PasteSpecial Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard
Set CopyRng = Wkb.Sheets(1).Range(Cells(i, 1).Address, Cells(i, 1).Address)
Set DestRng = shtDest.Range("C" & shtDest.Cells(Rows.Count, "O").End(xlDown).Row)
CopyRng.Copy
DestRng.PasteSpecial Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard
Set CopyRng = Wkb.Sheets(1).Range(Cells(i, 3).Address, Cells(i, 3).Address)
Set DestRng = shtDest.Range("S" & shtDest.Cells(Rows.Count, "O").End(xlUp).Row)
CopyRng.Copy
DestRng.PasteSpecial Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard
i = i + 2
Next i
'Dim cell As Integer
'Dim empname As String
'destLRow = 8 '' find out how to find first available row
'For cell = 2 To lRow
'empname = Wkb.Sheets(1).Cells(cell, 3).Value & " " & Wkb.Sheets(1).Cells(cell, 4).Value
' shtDest.Cells(8, 5).Value = empname
'shtDest.Cells(8, 1).Value = "Service Electric"
'Next cell
' Wkb.Close Save = False
End If
'End If
Filename = Dir()
Loop
MsgBox "Done!"
End Sub
if you want to do in VBA and want to copy one value in "ALL" column
Cells(1,1).Copy Columns(1)
Expected situation: I have a loop which is checking all sheets of a workbook for certain keywords, copy/pasting them according to certain conditions and ist creating a new workbook for every sheet with the said values.
Example:
Source Workbook with Sheet1,Sheet2 and Sheet3 --->
New_Workbook_1(with values of Sheet1), New_Workbook_2(with values of
Sheet2), New_Workbook_3(with values of Sheet3)
Actual situation: only the values of the last sheet of the workbook are pasted into the newly created workbooks...I can't tell why? .
Example:
Source Workbook with Sheet1,Sheet2 and Sheet3 ---> New_Workbook_1(with
values of Sheet3), New_Workbook_2(with values of Sheet3),
New_Workbook_3(with values of Sheet3)
Public Sub TransferFile(TemplateFile As String, SourceFile As String)
Dim wbSource As Workbook
Set wbSource = Workbooks.Open(SourceFile) 'open source
Dim rFnd As Range
Dim r1st As Range
Dim ws As Worksheet
Dim arr(1 To 4) As Variant
Dim i As Long
Dim wbTemplate As Workbook
Dim NewWbName As String
Dim wsSource As Worksheet
For Each wsSource In wbSource.Worksheets 'loop through all worksheets in source workbook
Set wbTemplate = Workbooks.Open(TemplateFile) 'open new template
'/* Definition of the value range */
arr(1) = "XX"
arr(2) = "Data 2"
arr(3) = "Test 3"
arr(4) = "XP35"
For i = LBound(arr) To UBound(arr)
For Each ws In wbSource.Worksheets
Debug.Print ws.Name
Set rFnd = ws.UsedRange.Find(what:=arr(i), LookIn:=xlValues, lookat:=xlPart, SearchOrder:=xlRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not rFnd Is Nothing Then
Set r1st = rFnd
Do
If i = 1 Then
wbTemplate.Sheets("Header").Range("A3").Value = "XX"
ElseIf i = 2 Then
wbTemplate.Sheets("Header").Range("B9").Value = rFnd.Offset(0, 1).Value
ElseIf i = 3 Then
wbTemplate.Sheets("Header").Range("D7").Value = rFnd.Offset(0, 2).Value
ElseIf i = 4 Then
wbTemplate.Sheets("MM1").Range("A8").Value = "2"
End If
Set rFnd = ws.UsedRange.FindNext(rFnd)
Loop Until r1st.Address = rFnd.Address
End If
Next
Next
NewWbName = Left(wbSource.Name, InStr(wbSource.Name, ".") - 1)
For i = 1 To 9
'check for existence of proposed filename
If Len(Dir(wbSource.Path & Application.PathSeparator & NewWbName & "_V" & i & ".xlsx")) = 0 Then
wbTemplate.SaveAs wbSource.Path & Application.PathSeparator & NewWbName & "_V" & i & ".xlsx"
Exit For
End If
Next i
wbTemplate.Close False 'close template
Next wsSource
wbSource.Close False 'close source
End Sub
Place a breakpoit on line ( by pressing F9 in that line) and run the program. When vba stopped at that line, before pressing F5 to continue, go to your folder and open newly created workbook and see is it true or not. continue and share the results to find out where is the issue.
I have a code with an If-yes and an If-no condition. The first few lines for each condition are different, while the rest of it is the exact same and performs the same operation. Can anyone point out as to how I can incorporate the part of the code that is exactly same in a function that can be called in either condition?
I am not well versed as to how I could move ahead with this. Any help would be appreciated. Thank you.
This is my code:
Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
fromRange.Copy
toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "%
completed"
DoEvents
End Sub
Sub Automate_Estimate()
Dim MyFile As String, Str As String, MyDir As String, DestWb As Workbook,
SrcWb As Workbook
Dim Rws As Long, Rng As Range
Dim DestName As String
Dim SourceName As String
Dim completed As Double
Dim flg As Boolean, sh As Worksheet
Dim ref As Long
'Dim DestRowCount As Long
Dim DestColCount As Long
Dim lnCol As Long
Dim last As Long
Dim destKey As String, sourceKey As String
Dim destTotalRows As Long
Dim i As Integer, j, k As Integer
Dim DestSheet As Worksheet
Dim SrcSheet As Worksheet
DestName = "x" 'Name of destination sheet
SourceName = "y" 'Name of Source sheet
MyDir = "\Path\"
'Default directory path"
Const steps = 22 'Number of rows copied
ref = 13 'row in y sheet in which 'Grand Total' is present
Set DestWb = ThisWorkbook 'Setting Destination workbook
' disable certain excel features to speed up the process
Application.DisplayAlerts = False
'Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim answer As Integer
answer = MsgBox("If you want to select a specific file click Yes, if you
want to go to default path, click No",vbYesNo + vbQuestion, "User Specified Path")
If answer = vbYes Then
MyFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
completed = 0
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
Set SrcWb = Workbooks.Open(MyFile, UpdateLinks:=0) 'Opening the Source workbook
(REPETITIVE CODE STARTS HERE)
completed = 0
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
'Find the last non-blank cell in row ref
lnCol = SrcWb.Sheets(SourceName).Cells(ref, Columns.Count).End(xlToLeft).Column
last = lnCol - 1 'To get penultimate column
Set DestSheet = DestWb.Sheets(DestName)
Set SrcSheet = SrcWb.Sheets(SourceName)
destTotalRows = DestSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Finding last non-blank cell in Column 1 in Destination sheet
'MsgBox "Last row is: " & destTotalRows
For i = 1 To destTotalRows
destKey = DestSheet.Cells(i, 1)
If destKey = "" Then GoTo endFor 'Ignoring blanks while looping through destination sheet
sourceKey = GetSourceKey(destKey)
If sourceKey = "" Then GoTo endFor 'Ignoring unmatched values while looping through source sheet
Debug.Print "DestKey", destKey, "SourceKey", sourceKey
k = DestSheet.Cells(1, 1).EntireColumn.Find(What:=destKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Destkey in Destination sheet
j = SrcSheet.Cells(1, 2).EntireColumn.Find(What:=sourceKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Srckey in Source sheet
Debug.Print j, k
Call CopyRange(SrcSheet.Range(Cells(j, 3), Cells(j, 3).End(xlToRight)), DestSheet.Cells(k, 2), completed) 'Copying the data from Source sheet and pasting it onto destiation sheet
completed = completed + (100 / steps)
endFor:
Next i
SrcWb.Close
Application.StatusBar = "Copying is complete"
DoEvents
ElseIf answer = vbNo Then
'change the address to suit
MyFile = Dir(MyDir & "Estimate*.xls*") 'change file extension
ChDir MyDir
Set SrcWb = Workbooks.Open(MyDir + MyFile, UpdateLinks:=0)
(REPETITIVE CODE STARTS HERE)
completed = 0
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
'Find the last non-blank cell in row ref
lnCol = SrcWb.Sheets(SourceName).Cells(ref, Columns.Count).End(xlToLeft).Column
last = lnCol - 1 'To get penultimate column
Set DestSheet = DestWb.Sheets(DestName)
Set SrcSheet = SrcWb.Sheets(SourceName)
destTotalRows = DestSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Finding last non-blank cell in Column 1 in Destination sheet
'MsgBox "Last row is: " & destTotalRows
For i = 1 To destTotalRows
destKey = DestSheet.Cells(i, 1)
If destKey = "" Then GoTo endFor 'Ignoring blanks while looping through destination sheet
sourceKey = GetSourceKey(destKey)
If sourceKey = "" Then GoTo endFor 'Ignoring unmatched values while looping through source sheet
Debug.Print "DestKey", destKey, "SourceKey", sourceKey
k = DestSheet.Cells(1, 1).EntireColumn.Find(What:=destKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Destkey in Destination sheet
j = SrcSheet.Cells(1, 2).EntireColumn.Find(What:=sourceKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Srckey in Source sheet
Debug.Print j, k
Call CopyRange(SrcSheet.Range(Cells(j, 3), Cells(j, 3).End(xlToRight)), DestSheet.Cells(k, 2), completed) 'Copying the data from Source sheet and pasting it onto destiation sheet
completed = completed + (100 / steps)
endFor:
Next i
SrcWb.Close
Application.StatusBar = "Copying is complete"
DoEvents
MyFile = Dir()
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ActiveSheet.DisplayPageBreaks = True
End Sub
basic coding principle is DRY -> Don't Repeat Yourself ;)
so move the resused code outside If clause, keeping there only the part where you decide which file to open
like so:
Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
fromRange.Copy
toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% "
completed ""
DoEvents
End Sub
Sub Automate_Estimate()
Dim MyFile As String, Str As String, MyDir As String, DestWb As Workbook, SrcWb As Workbook
Dim Rws As Long, Rng As Range
Dim DestName As String
Dim SourceName As String
Dim completed As Double
Dim flg As Boolean, sh As Worksheet
Dim ref As Long
'Dim DestRowCount As Long
Dim DestColCount As Long
Dim lnCol As Long
Dim last As Long
Dim destKey As String, sourceKey As String
Dim destTotalRows As Long
Dim i As Integer, j, k As Integer
Dim DestSheet As Worksheet
Dim SrcSheet As Worksheet
DestName = "x" 'Name of destination sheet
SourceName = "y" 'Name of Source sheet
MyDir = "\Path\"
'Default directory path"
Const steps = 22 'Number of rows copied
ref = 13 'row in y sheet in which 'Grand Total' is present
Set DestWb = ThisWorkbook 'Setting Destination workbook
' disable certain excel features to speed up the process
Application.DisplayAlerts = False
'Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim answer As Integer
answer = MsgBox("If you want to select a specific file click Yes, if you want to go to default path, click No", vbYesNo + vbQuestion, "User Specified Path")
If answer = vbYes Then
MyFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
completed = 0
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
Set SrcWb = Workbooks.Open(MyFile, UpdateLinks:=0) 'Opening the Source workbook
ElseIf answer = vbNo Then
'change the address to suit
MyFile = Dir(MyDir & "Estimate*.xls*") 'change file extension
ChDir MyDir
Set SrcWb = Workbooks.Open(MyDir + MyFile, UpdateLinks:=0)
End If
completed = 0
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "% completed"
'Find the last non-blank cell in row ref
lnCol = SrcWb.Sheets(SourceName).Cells(ref, Columns.Count).End(xlToLeft).Column
last = lnCol - 1 'To get penultimate column
Set DestSheet = DestWb.Sheets(DestName)
Set SrcSheet = SrcWb.Sheets(SourceName)
destTotalRows = DestSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Finding last non-blank cell in Column 1 in Destination sheet
'MsgBox "Last row is: " & destTotalRows
For i = 1 To destTotalRows
destKey = DestSheet.Cells(i, 1)
If destKey = "" Then GoTo endFor 'Ignoring blanks while looping through destination sheet
sourceKey = GetSourceKey(destKey)
If sourceKey = "" Then GoTo endFor 'Ignoring unmatched values while looping through source sheet
Debug.Print "DestKey", destKey, "SourceKey", sourceKey
k = DestSheet.Cells(1, 1).EntireColumn.Find(What:=destKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Destkey in Destination sheet
j = SrcSheet.Cells(1, 2).EntireColumn.Find(What:=sourceKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'Finding row with Srckey in Source sheet
Debug.Print j, k
Call CopyRange(SrcSheet.Range(Cells(j, 3), Cells(j, 3).End(xlToRight)), DestSheet.Cells(k, 2), completed) 'Copying the data from Source sheet and pasting it onto destiation sheet
completed = completed + (100 / steps)
endFor:
Next i
SrcWb.Close
Application.StatusBar = "Copying is complete"
DoEvents
MyFile = Dir()
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ActiveSheet.DisplayPageBreaks = True
End Sub
I am looping through all the excel files in a folder to get data from a particular sheet in each workbook and consolidating the data into a master workbook.
The problem is that the sheet name is 'Mthly KPI usd' in 9 of the 14 workbooks while the rest are different and I am not allowed to change the name of the worksheet.
How can I resolve this issue? Thank you.
This is my code :
Sub LoopThroughFolder()
Dim myCol As Long
Dim my_FileName As Variant
Dim i As Long
Dim lnRow As Long, lnCol As Long
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "E:\John\2017\"
MyFile = Dir(MyDir & "*.xl*") 'change file extension
ChDir MyDir
Dim current As String
current = CurDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
If MyFile = "Master.xlsm" Then
Exit Sub
End If
Workbooks.Open (MyDir + MyFile)
With Worksheets("Mthly KPI usd")
Rws = Cells(Rows.Count, "P").End(xlUp).Row
lnRow = 2
lnCol = ActiveSheet.Cells(lnRow, 1).EntireRow.Find(What:="Oct", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
MsgBox lnCol
Set Rng = Range(.Cells(4, lnCol), .Cells(Rws, lnCol))
Rng.Copy Wb.Sheets("Test").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
ActiveWorkbook.Close True
End With
MyFile = Dir()
Loop
End Sub
Replace the lines from
Workbooks.Open (MyDir + MyFile)
to
End With
with the following
Dim wb as Workbook
Dim ws as Worksheet
Set wb = Workbooks.Open (MyDir + MyFile)
For Each ws in wb.Worksheets
if InStr(1, ws.Name, "Mthly KPI") > 0 then
With ws
' Add your code which copies data from the source worksheet to the master worksheet
Rws = Cells(Rows.Count, "P").End(xlUp).Row
End ws
End If
Next ws
I have a workbook that can export the working sheet to a .csv but it copies it into a new workbook for a second before saving im wondering if there is a way just to copy data from the sheet as is without opening a new workbook ? the code i have is:
Sub CopyToCSV()
Dim FlSv As Variant
Dim MyFile As String
Dim sh As Worksheet
Dim MyFileName As String
Dim DateString As String
Application.ScreenUpdating = False
DateString = Format(Now(), "dd-mm-yyyy_hh-mm-ss-AM/PM") '<~~ uses current time from computer clock down to the second
MyFileName = "Results - " & DateString
Set sh = Sheets("Sheet1")
sh.Copy
FlSv = Application.GetSaveAsFilename(MyFileName, fileFilter:="CSV (Comma delimited) (*.csv), *.csv", Title:="Where should we save this?")
If FlSv = False Then GoTo UserCancel Else GoTo UserOK
UserCancel: '<~~ this code is run if the user cancels out the file save dialog
ActiveWorkbook.Close (False)
MsgBox "Export Canceled"
Exit Sub
UserOK: '<~~ this code is run if user proceeds with saving the file (clicks the OK button)
MyFile = FlSv
With ActiveWorkbook
.SaveAs (MyFile), FileFormat:=xlCSV, CreateBackup:=False
.Close False
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Try this (tested on a simple dataset)
Private Sub ExportToCsv()
Dim ws As Worksheet
Dim delim As String, LastCol As String, csvFile As String, CsvLine As String
Dim aCell As Range, DataRange As Range
Dim ff As Long, lRow As Long, lCol As Long
Dim i As Long, j As Long
'~~> We use "," as delimiter
delim = ","
'~~> Change this to specify your file name and path
csvFile = "C:\Users\Siddharth\Desktop\Sample.Csv"
'~~> Change this to the sheet which you want to export as csv
Set ws = ThisWorkbook.Sheets("Sheet9")
With ws
'~~> Find last row and last column
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lCol = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Column number to column letter
LastCol = Split(Cells(, lCol).Address, "$")(1)
'~~> This is the range which will be exported
Set DataRange = .Range("A1:" & LastCol & lCol)
'
'~~> Loop through cells in the range and write to text file
'
ff = FreeFile
Open csvFile For Output As #ff
For i = 1 To lRow
For j = 1 To lCol
CsvLine = CsvLine & (delim & Replace(.Cells(i, j).Value, """", """"""""))
Next j
Print #ff, Mid(CsvLine, 2)
CsvLine = ""
Next
'~~> Close text file
Close #ff
End With
End Sub
Sub CopyToCSV()
Dim FlSv As Variant
Dim MyFile As String
Dim sh As Worksheet
Dim MyFileName As String
Dim strTxt As String
Dim vDB, vR() As String, vTxt()
Dim i As Long, n As Long, j As Integer
Dim objStream
Dim strFile As String
Application.ScreenUpdating = False
DateString = Format(Now(), "dd-mm-yyyy_hh-mm-ss-AM/PM") '<~~ uses current time from computer clock down to the second
MyFileName = "Results - " & DateString
FlSv = Application.GetSaveAsFilename(MyFileName, fileFilter:="CSV (Comma delimited) (*.csv), *.csv", Title:="Where should we save this?")
If FlSv = False Then GoTo UserCancel Else GoTo UserOK
UserCancel: '<~~ this code is run if the user cancels out the file save dialog
ActiveWorkbook.Close (False)
MsgBox "Export Canceled"
Exit Sub
UserOK: '<~~ this code is run if user proceeds with saving the file (clicks the OK button)
Set objStream = CreateObject("ADODB.Stream")
MyFile = FlSv
vDB = ActiveSheet.UsedRange
For i = 1 To UBound(vDB, 1)
n = n + 1
ReDim vR(1 To UBound(vDB, 2))
For j = 1 To UBound(vDB, 2)
vR(j) = vDB(i, j)
Next j
ReDim Preserve vTxt(1 To n)
vTxt(n) = Join(vR, ",")
Next i
strtxt = Join(vTxt, vbCrLf)
With objStream
.Charset = "utf-8"
.Open
.WriteText strtxt
.SaveToFile FlSv, 2
.Close
End With
Set objStream = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub