I'm trying to delete all duplicate rows based on Column B and leave only the unique rows.
It will leave one of the duplicate entries. I tried with > 1 and = 2.
Sub test1()
Dim fName As String, fPath As String, wb As Workbook, sh As Worksheet, i As Long, lCopyLastRow As Long, lDestLastRow As Long
Set sh = ActiveSheet
fPath = ThisWorkbook.Path & "\"
fName = Dir(fPath & "*.xls*")
Do
If fName <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(fPath & fName)
lCopyLastRow = wb.Sheets(1).Cells(wb.Sheets(1).Rows.Count, "A").End(xlUp).Row
lDestLastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1).Row
wb.Sheets(1).Range("A2:AA1000" & lCopyLastRow).Copy sh.Range("B" & lDestLastRow)
sh.Range("A1") = "Source"
With sh
.Range(.Cells(Rows.Count, 1).End(xlUp)(2), .Cells(Rows.Count, 2).End(xlUp).Offset(, -1)) = fName
End With
wb.Close
End If
Set wb = Nothing
fName = Dir
Loop Until fName = ""
For i = sh.UsedRange.Rows.Count To 2 Step -1
If Application.CountIf(sh.Range("B:B"), sh.Cells(i, 2).Value) > 1 Then Rows(i).Delete
Next
End Sub
The problem with your code is, that you countIf on the remaining rows - if you already deleted the "other" duplicates the first one is a unique value in the then remaining list.
So you have to count the occurences before deleting.
Sub removeNonUniqueRows()
Dim arrCountOccurences As Variant
ReDim arrCountOccurences(2 To sh.UsedRange.Rows.Count)
Dim i As Long
For i = 2 To sh.UsedRange.Rows.Count
arrCountOccurences(i) = Application.CountIf(sh.Range("B:B"), sh.Cells(i, 2).Value)
Next
For i = sh.UsedRange.Rows.Count To 2 Step -1
If arrCountOccurences(i) > 1 Then sh.Rows(i).Delete
Next
End Sub
Related
I have multiple workbooks in a folder and i need to copy paste data from some of them based on naming convention. I am copy pasting data based on column names to a master sheet as order of columns in source files is not the same. Code pasted below does the task but it looks for exact match in column names and as a result i am only able to capture 80% of the data as few column names in source files are not an exact match. For eg: A column in the Target file with header Premium is mentioned as Premium # 25% in the Source file. This is just an example.
Sub ImportExcelfiles()
Dim strPath As String
Dim strFile As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim bookName As Worksheet
Dim rowCountSource As Long
Dim colCountSource As Long
Dim rowOutputTarget As Long
Dim colOutputTarget As Long
Dim found1 As Range, found2 As Range, j As Long, Cr1 As String, srcRow As Range
'Variables for Sheet - Workbook Name
Dim nameCount As Long
Dim fileName As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'====================================
'SET THE PATH AND FILE TO THE FOLDER
'====================================
strPath = ThisWorkbook.Worksheets("Control").Range("C4")
fileName = ThisWorkbook.Worksheets("Control").Range("C5")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'set the target worksheet
Set wsTarget = ThisWorkbook.Worksheets("Master Data")
Set bookName = ThisWorkbook.Worksheets("Workbook Name")
'set the initial output row and column count for master data and workbook name
nameCount = 2
rowOutputTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop throught the excel files in the folder
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile)
Set wsSource = wbSource.Worksheets("Details")
'get the row and column counts
With wsSource
colCountSource = .Cells(2, Columns.Count).End(xlToLeft).Column
For j = 1 To colCountSource
Cr1 = .Cells(2, j).Value
Set srcRow = .Range("A2", .Cells(1, colCountSource))
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=True)
If Not found1 Is Nothing Then
colCountSource = wsTarget.Cells(1, Columns.Count).End(xlToLeft).Column
Set srcRow = wsTarget.Range("A1", wsTarget.Cells(1, colCountSource))
Set found2 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=F)
If Not found2 Is Nothing Then
rowCountSource = .Cells(Rows.Count, found1.Column).End(xlUp).Row
.Range(.Cells(3, found1.Column), .Cells(rowCountSource, found1.Column)).Copy
found2.Offset(rowOutputTarget, 0).PasteSpecial Paste:=xlPasteValues
End If
End If
Next j
End With
bookName.Range("A" & nameCount).Value = wbSource.Name
'update output row '2+12-1=13
nameCount = nameCount + 1
rowOutputTarget = rowOutputTarget + rowCountSource - 2
'close the opened workbook
wbSource.Close SaveChanges:=False
End If
'get the next file
strFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Data imported.", vbInformation
End Sub
This code takes approximately 5 mins to copy paste data. Is there a way to optimise it and also solve my problem of missing 20% data.
Because the target column name is the shorter you need to search the source column names for each target column name.
Option Explicit
Sub ImportExcelfiles()
Dim strPath As String, strFile As String, fileName As String
Dim wbSource As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim bookName As Worksheet
Dim rowCountSource As Long, colCountSource As Long
Dim colCountTarget As Long
Dim rowOutputTarget As Long, colOutputTarget As Long
Dim found1 As Range, found2 As Range, j As Long
Dim Cr1 As String, srcRow As Range
'Variables for Sheet - Workbook Name
Dim nameCount As Long
Dim t0 As Single: t0 = Timer
strPath = ThisWorkbook.Worksheets("Control").Range("C4")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
fileName = ThisWorkbook.Worksheets("Control").Range("C5")
'set the target worksheet
With ThisWorkbook
Set wsTarget = .Sheets("Master Data")
Set bookName = .Sheets("Workbook Name")
End With
'set the initial output row and column count
'for master data and workbook name
nameCount = 2
Dim arTarget, rngSrc As Range, rngTarget As Range
Dim lastrow As Long, n As Long
With wsTarget
rowOutputTarget = 1 + .Cells(.Rows.Count, 1).End(xlUp).Row
' array of target column names
colCountTarget = .Cells(1, .Columns.Count).End(xlToLeft).Column
arTarget = .Cells(1, 1).Resize(, colCountTarget)
End With
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop throught the excel files in the folder
Application.ScreenUpdating = False
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile, ReadOnly:=True)
Set wsSource = wbSource.Worksheets("Details")
With wsSource
'get the row and column counts'get the row and column counts
colCountSource = .Cells(2, Columns.Count).End(xlToLeft).Column
Set srcRow = .Range("A2", .Cells(1, colCountSource))
' loop through target columns
For j = 1 To UBound(arTarget, 2)
Cr1 = arTarget(1, j)
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlPart, MatchCase:=True)
' found
If Not found1 Is Nothing Then
rowCountSource = .Cells(.Rows.Count, found1.Column).End(xlUp).Row
n = rowCountSource - 2
Set rngSrc = .Range(.Cells(3, found1.Column), .Cells(rowCountSource, found1.Column))
Set rngTarget = wsTarget.Cells(rowOutputTarget, j)
rngTarget.Resize(n).Value2 = rngSrc.Value2
If lastrow < rowOutputTarget + n Then
lastrow = rowOutputTarget + n
End If
End If
Next
End With
bookName.Range("A" & nameCount).Value = wbSource.Name
'update output row '2+12-1=13
nameCount = nameCount + 1
rowOutputTarget = lastrow
'close the opened workbook
wbSource.Close SaveChanges:=False
End If
'get the next file
strFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Data imported.", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
Extracting a range of non-contiguous cells within number of excel files in a particular folder (data has to be pulled from either of 2 UNIQUE SHEETS)
I have the below code for pulling data (range of cells) that are non-contiguous and pasting them in a new sheet. However, the code needs to look for the data in either of the 2 sheets , namely - "summary1" or "extract1".
[Note- Only one of the two sheets would be available in each file]
I can successfully pull for one of them but if i add both of them using "On Error Resume Next" i get an error. Kindly guide me on how to resolve this!
Any suggestions or tips are much appreciate!!
Code:
Sub PIdataextraction()
Dim myFile As String, path As String
Dim erow As Long, col As Long
path = "C:\Users\New\"
myFile = Dir(path & "*.xl??")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
Set copyrange = Sheets("summary1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
On Error Resume Next
Set copyrange = Sheets("extract1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
Windows("MasterFile.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
cel.Copy
Cells(erow, col).PasteSpecial xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled,Please Check!"
End Sub
Here's one approach which factors out the "find one of these sheets in a workbook" logic into a separate function.
Sub PIdataextraction()
Const PTH As String = "C:\Users\New\" 'use const for fixed values
Const RNG As String = "B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16"
Dim myFile As String, path As String, c As Range
Dim erow As Long, col As Long, wb As Workbook, ws As Worksheet
Application.ScreenUpdating = False
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row
myFile = Dir(PTH & "*.xl??")
Do While myFile <> ""
Set wb = Workbooks.Open(path & myFile)
Set ws = FindFirstSheet(wb, Array("summary1", "extract1"))
If Not ws Is Nothing Then 'check we got a sheet
col = 1
For Each c In ws.Range(RNG).Cells
Sheet1.Cells(erow, col).Value = c.Value
col = col + 1
Next c
Sheet1.Cells(erow, col).Value = wb.Name '<<<<<<<<<<<<<<<<
erow = erow + 1
Else
Debug.Print "No sheet found in " & ws.Name
End If
wb.Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled,Please Check!"
End Sub
'Given a workbook `wb`, return the first sheet found from
' an array of sheet names `SheetNames`
Function FindFirstSheet(wb As Workbook, SheetNames) As Worksheet
Dim ws As Worksheet, s
For Each s In SheetNames
On Error Resume Next
Set ws = wb.Worksheets(s)
On Error GoTo 0
If Not ws Is Nothing Then Exit For
Next s
Set FindFirstSheet = ws
End Function
The following code worked for me. As usual thank you for your valuable inputs!! much appriciated
Sub PIdataextraction()
Dim myFile As String, path As String
Dim erow As Long, col As Long
Dim shtSrc As Worksheet
Dim copyrange As Range, cel As Range
path = "C:\Users\New\"
myFile = Dir(path & "*.xl??")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
On Error Resume Next
Set shtSrc = Worksheets("summary1")
If Err = 9 Then
On Error Resume Next
Set shtSrc = Worksheets("extract1")
If Err = 9 Then Exit Sub
On Error GoTo 0
End If
Set copyrange = shtSrc.Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
Windows("MasterFile.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
Cells(erow, col).Value = cel.Value ' Equivalent of xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled,Please Check!"
End Sub
Would like seek help on simplifying down some codes. it worked on some smaller set of data but unable to work on this larger set of around 750rows of data. The aim is to simplify down the data set by the criteria of Banker, and saved each filtered results based on Banker on a new tab, and then save as a separate workbook.
Sub seperate_by_banker()
Dim i, n As Integer
Dim banker As String
i = 2
n = Sheets("Banker").Range("A1").End(xlDown).Row
Do Until i = n
banker = Sheets("Banker").Range("A" & i)
Sheets("ASIA CHINA (PC)").Select
ActiveSheet.Range("$A$1:$Y$1000").AutoFilter Field:=7, Criteria1:= _
banker
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Name = banker
i = i + 1
Loop
Call SplitWorkbook
End Sub
Sub SplitWorkbook()
'Updateby20200806
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
MkDir FolderName
For Each xWs In xWb.Worksheets
On Error GoTo NErro
If xWs.Visible = xlSheetVisible Then
xWs.Select
xWs.Copy
xFile = FolderName & "\" & xWs.Name & FileExtStr
Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
xNWb.SaveAs xFile, FileFormat:=FileFormatNum
xNWb.Close False, xFile
End If
NErro:
xWb.Activate
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub
Please, try the next code. It uses array and copy the filtered range after transforming it in an array, so it should be very fast. No need of the second sub, no need of selections, which only consume Excel resources:
Sub seperate_by_banker()
Dim shB As Worksheet, shAC As Worksheet, wbNew As Workbook, lastR As Long, lastRAC As Long
Dim banker As String, rng As Range, rngF As Range, arrB, arr, i As Long, FolderName As String
Set shB = ThisWorkbook.Sheets("Banker")
lastR = shB.Range("A" & shB.rows.count).End(xlUp).row 'last row
arrB = shB.Range("A2:A" & lastR).Value2
Set shAC = ThisWorkbook.Sheets("ASIA CHINA (PC)")
lastRAC = shAC.Range("A" & shAC.rows.count).End(xlUp).row 'last row
FolderName = ThisWorkbook.path & "\" & ThisWorkbook.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
If Dir(FolderName, vbDirectory) = "" Then MkDir FolderName 'create the folder if it does not exist
For i = 1 To UBound(arrB)
banker = arrB(i, 1)
shAC.AutoFilterMode = False 'eliminate the previous filter, if any
Set rng = shAC.Range("A1:Y" & lastRAC) 'set the range to be processed
rng.AutoFilter field:=6, Criteria1:=banker
Set rngF = rng.SpecialCells(xlCellTypeVisible) 'set a range to keep the filtered cells in the range
arr = arrayFromDiscRange(rngF, False) 'header inclusive
'create the necessary new workbook:
Set wbNew = Workbooks.Add
With wbNew.Sheets(1).Range("A1").Resize(UBound(arr), UBound(arr, 2))
.value = arr
.EntireColumn.AutoFit
End With
wbNew.saveas FolderName & "\" & banker & ".xlsx"
wbNew.Close False
Next i
End Sub
And the necessary function. It transforms the filtered (discontinuous) range in an array and paste it as fast as possible:
Private Function arrayFromDiscRange(rngF As Range, Optional NoHeader As Boolean = False) As Variant
Dim arr, i As Long, j As Long, k As Long, A As Range, R As Range, iRows As Long
'count range rows
For Each A In rngF.Areas
iRows = iRows + A.rows.count
Next A
'Redim the array to keep the range
ReDim arr(1 To iRows - IIf(NoHeader, 1, 0), 1 To rngF.Columns.count): k = 1
For Each A In rngF.Areas 'iterate between the range areas:
For Each R In A.rows 'iterate between the area rows:
If NoHeader And k = 1 Then GoTo Later 'skip the first row, if no header wanted
For j = 1 To R.Columns.count 'iterate between the area row columns:
arr(k, j) = R.cells(1, j).value 'place each row cells value in the array row
Next j
k = k + 1 'increment the array row to receive values
Later:
Next
Next A
arrayFromDiscRange = arr 'returning the created array
End Function
You could create the new workbooks directly from the filtered sheet.
Option Explicit
Sub separate_by_banker()
Dim wb As Workbook, wbNew As Workbook
Dim ws As Worksheet, wsData As Worksheet
Dim rng As Range, arBanker As Variant
Dim n As Long, iLastRow As Long
Dim foldername As String, sName As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Banker")
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
arBanker = ws.Range("A2:A" & iLastRow).Value2
Set wsData = wb.Sheets("ASIA CHINA (PC)")
iLastRow = wsData.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = wsData.Range("A1:Y" & iLastRow)
' make folder for workbooks
foldername = wb.Path & "\" & wb.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
MkDir foldername
Application.ScreenUpdating = False
For n = 1 To UBound(arBanker)
sName = arBanker(n, 1)
Set wbNew = Workbooks.Add(xlWBATWorksheet) ' 1 sheet
wbNew.Sheets(1).Name = sName
rng.AutoFilter Field:=7, Criteria1:=sName
rng.Copy
wbNew.Sheets(1).Paste
wbNew.Sheets(1).Columns("A:Y").AutoFit
wbNew.SaveAs foldername & "\" & sName & ".xlsx"
wbNew.Close False
Next
wsData.AutoFilterMode = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox n-1 & " files created in " & foldername, vbInformation
End Sub
The below code is take the Status of Col"E" If it is = Include then its corresponding sheets ranges will will be converted to PDF.
I have tried at my end but its not working receiving an error invalid procedure call or argument on the line
rng.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation
Your help will be appreciated to fix the problem.
Sub SelectSheets_Ranges()
Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
ReDim arr(lastR - 1)
For i = 6 To lastR
If sh.Range("E" & i).Value = "Include" Then
arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value: k = k + 1
End If
Next i
ReDim Preserve arr(k - 1)
For i = 0 To UBound(arr)
arrSplit = Split(arr(i), "|")
Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
'Create and assign variables
Dim saveLocation As String
saveLocation = "C:\Users\marks\OneDrive\Documents\myPDFFile.pdf"
'Save a range as PDF
rng.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation
Next
End Sub
Please, try the next code. It saves in ThisWorkbook path, naming the pdf file as "myPDFFile_sheetName.pdf". Each created file will be open in the default pdf application. If it works OK, you can appropriately change the last parameter:
Sub SelectSheets_Ranges_ExpPdf()
Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
ReDim arr(lastR - 1)
For i = 6 To lastR
If sh.Range("E" & i).Value = "Include" Then
arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value: k = k + 1
End If
Next i
If k > 0 Then
ReDim Preserve arr(k - 1)
Else
MsgBox "No appropriate range (containing ""Include"") could be found...:exit sub"
End If
Dim boolHide As Boolean, boolProt As Boolean
ActiveWorkbook.Unprotect "4321" 'in order to unprotect he workbook structure
For i = 0 To UBound(arr)
boolHide = False: boolProt = False
arrSplit = Split(arr(i), "|")
Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
If ActiveWorkbook.Sheets(arrSplit(0)).ProtectContents Then _
ActiveWorkbook.Sheets(arrSplit(0)).Unprotect "4321": boolProt = True
Debug.Print arrSplit(0)
If ActiveWorkbook.Sheets(arrSplit(0)).Visible <> xlSheetVisible Then _
ActiveWorkbook.Sheets(arrSplit(0)).Visible = xlSheetVisible: boolHide = True
'Create and assign variables
Dim saveLocation As String
saveLocation = ThisWorkbook.Path & "\myPDFFile_" & arrSplit(0) & ".pdf"
'Save a range as PDF
rng.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
saveLocation, Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=True
If boolHide Then ActiveWorkbook.Sheets(arrSplit(0)).Visible = xlSheetHidden
If boolProt Then ActiveWorkbook.Sheets(arrSplit(0)).Protect "4321"
Next
ActiveWorkbook.Protect "4321"
End Sub
Try this:
Sub SelectSheets_Ranges()
Dim sh As Worksheet, i As Long
Dim saveLocation As String, FirstSheet As Boolean
saveLocation = "C:\Users\marks\OneDrive\Documents\myPDFFile.pdf"
Set sh = ActiveSheet
FirstSheet = True
For i = 6 To sh.Range("C" & sh.Rows.Count).End(xlUp).Row
If sh.Cells(i, "E") = "Include" Then
'FirstSheet determines whether the sheet is added to currently-selected
' sheets or not (if not then it replaces them)
ThisWorkbook.Sheets(sh.Cells(i, "C").Value).Select FirstSheet
FirstSheet = False
End If
Next i
If Not FirstSheet Then
'at least one sheet was included
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=saveLocation
End If
End Sub
I assume you want all the ranges from the different sheets in one pdf.
Option Explicit
Sub SelectSheets_Ranges()
Const FOLDER = "C:\Users\marks\OneDrive\Documents\"
Const FILENAME = "myPDFFile.pdf"
Dim wb As Workbook, wbPDF As Workbook
Dim sh As Worksheet, wsPDF As Worksheet
Dim lastR As Long, rng As Range, r As Long, n As Integer, m As Integer
Set sh = ActiveSheet
Set wb = ActiveWorkbook
lastR = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
' create temp workbook to hold ranges
Set wbPDF = Workbooks.Add
m = wbPDF.Sheets.Count
n = m
With sh
For r = 6 To lastR
If .Cells(r, "E").Value = "Include" Then
Set rng = wb.Sheets(.Cells(r, "C").Value).Range(.Cells(r, "D").Value)
Set wsPDF = wbPDF.Sheets.Add(After:=wbPDF.Sheets(n))
rng.Copy wsPDF.Range("A1")
n = n + 1
End If
Next
End With
' delete initial sheets
Application.DisplayAlerts = False
For n = m To 1 Step -1
wbPDF.Sheets(n).Delete
Next
Application.DisplayAlerts = True
'end
wbPDF.ExportAsFixedFormat Type:=xlTypePDF, FILENAME:=FOLDER & FILENAME
'wbPDF.SaveAs FOLDER & "debug.xlsx"
wbPDF.Close False
MsgBox "PDF created " & FOLDER & FILENAME, vbInformation
End Sub
I have some csv files in one folder. They all contain 3 specific columns. The number of total columns and the order may vary.
I want to concatenate all 3 columns with an underscore and write them in a single column in the worksheet that is running the code.
Here is what I have so far:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
Cells(i, 1) = Cells(i, Columns(0)) & "_" & Cells(i, Columns(1)) & "_" & Cells(i, Columns(2))
Next i
End Sub
As you can see, this does what I want, but only for the active sheet.
I actually want to loop through all csv files in the same folder as the active sheet and write the results in the first sheet, first column of the sheet running the code (which is not a csv itself obviously).
How can I do this?
thanks!
This is a code that will loop through a folder
Sub Button1_Click()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\WorkBookLoop\"
MyFile = Dir(MyDir & "*.xls") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
'do something here
MyFile = Dir()
Loop
End Sub
It depends how you are naming the worksheets you create from the CSV files. You could add all the worksheets to a collection and use a For...Each loop to execute the entire search and concatenate procedure within that loop. Note that you'd have to explicitly define the first sheet name as this won't change through successive loops:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Dim frontSheet as Worksheet
Dim wSheets as New Collection
Dim ws as Worksheet
Set frontSheet = Sheets("name of front sheet")
'Add all your CSV sheets to wSheets using the .Add() method.
For Each ws in wSheets
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = ws.Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
frontsheet.Cells(i, 1) = ws.Cells(i, Columns(0)) & "_" & ws.Cells(i, Columns(1)) & "_" & ws.Cells(i, Columns(2))
Next i
Next ws
End Sub
It's often slow and labourious to open CSV files in excel but VBA can read them as text files using a TextStream. Furthermore, file scripting objects let you work with files and directories directly. Something like this might be a better approach if you don't need to keep the files in a worksheet afterwards:
Sub SearchFoldersForCSV()
Dim fso As Object
Dim fld As Object
Dim file As Object
Dim ts As Object
Dim strPath As String
Dim lineNumber As Integer
Dim lineArray() As String
Dim cols() As Integer
Dim i As Integer
Dim frontSheet As Worksheet
Dim frontSheetRow As Integer
Dim concatString As String
Set frontSheet = Sheets("name of front sheet")
frontSheetRow = 1
strPath = "C:\where-im-searching\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
For Each file In fld.Files
If (Right(file.Name, 3) = "csv") Then
Debug.Print file.Name
Set ts = file.OpenAsTextStream()
lineNumber = 0
Do While Not ts.AtEndOfStream
lineNumber = lineNumber + 1
lineArray = Split(ts.ReadLine, ",")
If (lineNumber = 1) Then
'We are at the first line of the .CSV so
'find index in lineArray of columns of interest
'Add extra ElseIf as required
For i = LBound(lineArray) To UBound(lineArray)
If lineArray(i) = "Column 1" Then
cols(1) = i
ElseIf lineArray(i) = "Column 2" Then
cols(2) = i
ElseIf lineArray(i) = "Column 3" Then
cols(3) = i
End If
Next i
Else
'Read and store the column of interest from this
'row by reading the lineArray indices found above.
concatString = ""
For i = LBound(cols) To UBound(cols)
concatString = concatString & lineArray(i) & "_"
Next i
concatString = Left(concatString, Len(concatString) - 1)
frontSheet.Cells(frontSheetRow, 1).Value = concatString
frontSheetRow = frontSheetRow + 1
End If
Loop
ts.Close
End If
Next file
End Sub
You can find more information on FileSystemObject and TextStream here.