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
Related
How do I find a value with the Find function?
I want to copy specific data from an external Excel file to the current workbook.
I added Option Explicit to test for errors but it could just spot that I didn't declare the variable. The output is the same.
Sub ReadDataFromCloseFile()
'
' ReadDataFromCloseFile Macro
'
'
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ThisWorkbook
Dim src As Workbook
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open("C:\test.xlsm", True, True)
Dim masterRow_count As Integer
masterRow_count = wb.Worksheets("Sheet1").Range("A1").End(xlDown).Row
Dim row_number As Integer
row_number = 2
Dim strSearch As String
Dim searchrange As Range
Do
Dim result As Range
strSearch = wb.Worksheets("Sheet1").Range("A" & row_number).Value
Set searchrange = src.Worksheets("Sheet1").Range("D:D")
Set result = searchrange.Find(what:=strSearch, LookIn:=xlValues, lookat:=xlValues)
If Not result Is Nothing Then
'Get the data from Asiamiles
src.Worksheets("Sheet1").Range("AB" & result.Row).Copy wb.Worksheets("Sheet1").Range("B", row_number)
src.Worksheets("Sheet1").Range("J" & result.Row).Copy wb.Worksheets("Sheet1").Range("C", row_number)
src.Worksheets("Sheet1").Range("I" & result.Row).Copy wb.Worksheets("Sheet1").Range("D", row_number)
src.Worksheets("Sheet1").Range("N" & result.Row).Copy wb.Worksheets("Sheet1").Range("E", row_number)
src.Worksheets("Sheet1").Range("AD" & result.Row).Copy wb.Worksheets("Sheet1").Range("F", row_number)
src.Worksheets("Sheet1").Range("P" & result.Row).Copy wb.Worksheets("Sheet1").Range("G", row_number)
src.Worksheets("Sheet1").Range("Q" & result.Row).Copy wb.Worksheets("Sheet1").Range("H", row_number)
End If
row_number = row_number + 1
Loop Until row_number = masterRow_count
src.Close SaveChanges:=False
Set src = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
There is another problem .It could not close the Excel workbook. But that is not the largest issue.
LookAt:=xlValues should be LookAt:=xlPart or LookAt:=xlWhole, Range("B", row_number) should be Range("B" & row_number)
Option Explicit
Sub ReadDataFromCloseFile()
Const SRC_WB = "C:\test.xlsm"
Dim wb As Workbook, wbSrc As Workbook
Dim ws As Worksheet, wsSrc As Worksheet
Dim masterRow_count As Long, row_number As Long
Dim rngSearch As Range, rngResult As Range, strSearch As String
Dim i As Long, n As Long, ar, t0 As Single
t0 = Timer
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Application.ScreenUpdating = False
Set wbSrc = Workbooks.Open(SRC_WB, True, True)
Set wsSrc = wbSrc.Worksheets("Sheet1")
With wsSrc
i = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rngSearch = wsSrc.Range("D1:D" & i)
End With
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
ar = Split("AB,J,I,N,AD,P,Q", ",")
With ws
masterRow_count = .Range("A" & .Rows.Count).End(xlUp).Row
For row_number = 2 To masterRow_count
strSearch = .Range("A" & row_number).Value
Set rngResult = rngSearch.Find(what:=strSearch, _
LookIn:=xlValues, lookat:=xlWhole)
If Not rngResult Is Nothing Then
'Get the data from Asiamiles
For i = 0 To UBound(ar)
.Cells(row_number, "B").Offset(0, i) = wsSrc.Cells(rngResult.Row, ar(i))
Next
n = n + 1
End If
Next
End With
wbSrc.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox row_number - 1 & " rows scanned, " & _
n & " rows updated", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
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
I have a document that contains a couple of macros.
First extracts data from a data sheet (datasheet) and copies to a specific worksheet (reportsheet) when the criteria is met.
Second saves this as a PDF, creates an email and sends it.
I have 100+ sheets and would require duplicating these macros 100 times.
I want to combine these into one macro. I would like to loop through a range ("B6:B123") and if in that range the cell <> 0 then the macro needs to run but the report sheet reference I'd like to update dynamically using the adjacent cell value (Dx) that would trigger these to run.
Macro 1
Sub Search_extract_135()
Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Dim ocname As String
Dim finalrow As Integer
Dim i As Integer
Set datasheet = Sheet121 ' stays constant
Set reportsheet = Sheet135 'need to update based on range that <>0 then taking cell reference as
ocname = reportsheet.Range("A1").Value 'stays constant
reportsheet.Range("A1:U499").EntireRow.Hidden = False
reportsheet.Range("A5:U499").ClearContents
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To finalrow
If Cells(i, 1) = ocname Then
Range(Cells(i, 1), Cells(i, 21)).Copy
reportsheet.Select
Range("A500").End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
datasheet.Select
End If
Next i
reportsheet.Select
Range("A4").Select
Call HideRows
End Sub
Macro 2
Sub Send_Email_135()
Dim wPath As String, wFile As String, wMonth As String, strPath As String, wSheet As Worksheet
Set wSheet = Sheet135
wMonth = Sheets("Journal").Range("K2")
wPath = ThisWorkbook.Path ThisWorkbook.Path
wFile = wSheet.Range("A1") & ".pdf"
wSheet.Range("A1:U500").ExportAsFixedFormat Type:=xlTypePDF, Filename:=wPath & "-" & wFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
strPath = wPath & "-" & wFile
Set dam = CreateObject("Outlook.Application").CreateItem(0)
'
dam.To = wSheet.Range("A2")
dam.cc = wSheet.Range("A3")
dam.Subject = "Statement " & wMonth
dam.Body = "Hi" & vbNewLine & vbNewLine & "Please find attached your statement." & Chr(13) & Chr(13) & "Regards," & Chr(13) & "xxxxx"
dam.Attachments.Add strPath
dam.Send
MsgBox "Email sent"
End Sub
The Excel document has names in column A, numeric values in column B and SheetCode in column D.
When cell within Range("B6:B123") <> 0 then run the two macros above but need report sheet from macro 1 & wSheet from macro 2 to use the same value in column D to references the specific worksheet code for the person that doesn't equal 0.
The solution it to use a dictionary to convert the codenames into sheet numbers and pass parameters into the subroutines so the same code can be applied to many different sheets.
Option Explicit
Sub Reporter()
' Journal sheet layout
Const ROW_START = 6
Const COL_NZ = "B" ' column to check <> 0
Const COL_CODE = "D" ' sheet codenames
' Fixed sheet code names
Const WS_DATA = "Sheet121"
Const WS_JOURNAL = "Sheet5"
Dim wb As Workbook, ws As Worksheet
Dim wsReport As Worksheet, wsJournal As Worksheet, wsData As Worksheet
Dim iLastRow As Long, i As Long, n As Long
Dim sCodeName As String, sMonth As String
' build a dictionary of codename->sheetno
Dim dict As Object, key As String
Set dict = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
For Each ws In wb.Sheets
dict.Add ws.CodeName, ws.Index
Next
' assign Fixed sheets
Set wsData = wb.Sheets(dict(WS_DATA)) ' or Sheet121
Set wsJournal = wb.Sheets(dict(WS_JOURNAL)) ' or Sheet5
sMonth = wsJournal.Range("K2")
' scan list of persons
With wsJournal
iLastRow = .Cells(Rows.Count, COL_CODE).End(xlUp).Row
For i = ROW_START To iLastRow
If .Cells(i, COL_NZ) <> 0 Then ' col B
sCodeName = .Cells(i, COL_CODE) ' col D
' set sheet, create report and email it
Set wsReport = wb.Sheets(dict(sCodeName))
Call Create_Report(wsReport, wsData)
Call Email_Report(wsReport, sMonth)
n = n + 1
End If
Next
End With
MsgBox n & " emails sent", vbInformation
End Sub
Sub Create_Report(wsReport As Worksheet, wsData)
Dim ocname As String, iLastRow As Long, i As Long
Dim rngReport As Range
With wsReport
ocname = .Range("A1").Value 'stays constant
.Range("A1:U500").EntireRow.Hidden = False
.Range("A5:U500").ClearContents
Set rngReport = .Range("A5")
End With
' scan down data sheet and copy to report sheet
Application.ScreenUpdating = False
With wsData
iLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To iLastRow
If wsData.Cells(i, 1) = ocname Then
.Cells(i, 1).Resize(1, 21).Copy rngReport
Set rngReport = rngReport.Offset(1)
End If
Next i
End With
'Call HideRows
Application.ScreenUpdating = True
End Sub
Sub Email_Report(wsReport As Worksheet, sMonth As String)
Dim sPDFname As String, oMail As Outlook.MailItem
sPDFname = ThisWorkbook.Path & "\" & wsReport.Range("A1") & ".pdf"
Dim oOut As Object ' Outlook.Application
Set oOut = CreateObject("Outlook.Application")
Set oMail = oOut.CreateItem(0)
With oMail
wsReport.Range("A1:U500").ExportAsFixedFormat _
Type:=xlTypePDF, Filename:=sPDFname, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
.To = wsReport.Range("A2").Value2
.cc = wsReport.Range("A3").Value2
.Subject = "Statement " & sMonth
.Body = "Hi" & vbNewLine & vbNewLine & _
"Please find attached your statement." & vbCr & vbCr & _
"Regards," & vbCr & "xxxxx"
.Attachments.Add sPDFname
.Display ' or .Send
End With
MsgBox "Email sent to " & wsReport.Range("A2").Value2, , wsReport.Name
oOut.Quit
End Sub
I'm trying to create an Excel tool to split a sheet of data into multiple .csv files, to a maximum of 200 rows per csv file.
My code:
Dim CSheet As Worksheet
Dim LastRow As Long
Dim LastCol As Long
Dim currentFilePath As String
Dim filePath As String
Dim dataDate As String
Dim n As Integer
Dim r As Integer
Dim rowStartNumber As Integer
Dim rowEndNumber As Integer
Dim numOfFiles As Integer
'*****************************************************
' Declare variables
'*****************************************************
On Error Resume Next
Application.DisplayAlerts = False
Set CSheet = Worksheets("Cleaned_Data")
Worksheets("Cleaned_Data").Activate
LastRow = CSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = CSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Debug.Print (Application.ActiveWorkbook.Path)
currentFilePath = Application.ActiveWorkbook.Path
numOfFiles = (LastRow - 1) / 200
dataDate = Format(Worksheets("Instructions").Cells(14, 2), "DD-MMM-YYYY")
filePath = currentFilePath & "\" & dataDate
'*****************************************************
' Check if folder exists; if yes delete and recreate
'*****************************************************
'if folder does not exist
If Dir(filePath, vbDirectory) = "" Then
MkDir filePath
Else
Kill filePath & "*.*"
RmDir filePath
MkDir filePath
End If
Debug.Print ("Hello")
' Loop to create the files
For n = 1 To numOfFiles
rowStartNumber = 2 + ((n - 1) * 200)
rowEndNumber = rowStartNumber + 199
Debug.Print (rowStartNumber & " - " & rowEndNumber)
For r = rowStartNumber To rowEndNumber
Debug.Print (rowStartNumber)
'Start to get data from Csheet, up to 200 rows, and write them into a new .csv file in filePath
Next r
Next n
The loop section is what I'm struggling with. I've tried many ways of copying pasting, or going row by row to iterate and write the .csv file out. How can I do that using VBA?
' Loop to create the files
For n = 1 To numOfFiles
rowStartNumber = 2 + ((n - 1) * 200) 'first data row starts at row 2, due to headers
rowEndNumber = rowStartNumber + 199
Debug.Print (rowStartNumber & " - " & rowEndNumber)
For r = rowStartNumber To rowEndNumber
Debug.Print (rowStartNumber)
'Start to get data from Csheet, up to 200 rows, and write them into a new .csv file in filePath
Next r
Next n
As comments suggested, the code below will aggregate the data in a new worksheet, then save that as a CSV in the same directory as the original Workbook, I've also added a number to the filename to distinguish between the split files:
Sub SplitToCSV()
Dim CSheet As Worksheet: Set CSheet = Worksheets("Cleaned_Data")
Dim ws As Worksheet
Dim LastRow As Long, LastCol As Long, numOfFiles As Integer
Dim filePath As String, dataDate As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
LastRow = CSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = CSheet.Cells(1, Columns.Count).End(xlToLeft).Column
dataDate = Format(Worksheets("Instructions").Cells(14, 2), "DD-MMM-YYYY")
WName = Left(Application.ActiveWorkbook.Name, InStr(Application.ActiveWorkbook.Name, ".") - 1)
numOfFiles = (LastRow - 1) / 200
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Temp"
'create a Temp Worksheet
For i = 1 To numOfFiles
filePath = Application.ActiveWorkbook.Path & "\" & WName & " " & dataDate & " - " & i
'Append the filenumber to the end of the filename
ws.Rows(1).Value = CSheet.Rows(1).Value
'copy headers
If i = 1 Then
CSheet.Range(CSheet.Cells(1 + (200 * (i - 1)), 1), CSheet.Cells(i * 200, LastCol)).Copy ws.Range("A1")
Else
CSheet.Range(CSheet.Cells(1 + (200 * (i - 1)), 1), CSheet.Cells(i * 200, LastCol)).Copy ws.Range("A2")
End If
'transfer data to Temp worksheet
ws.Copy
ActiveWorkbook.SaveAs Filename:=filePath, FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
'Save worksheet as CSV
Next i
ws.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You could try something along these lines, i have set a constant file count, you can use your original dividing code to sort that out :
Private Const cstChunkSize As Long = 200
Sub implementation()
Dim lngFileNum As Long
Dim wbExport As Excel.Workbook
Dim wsExport As Excel.Worksheet
Dim lngCols As Long
Dim rngChunk As Excel.Range
lngCols = 20
For lngFileNum = 1 To 10
Set wbExport = Workbooks.Add
Set wsExport = wbExport.Worksheets(1)
Set rngChunk = GetChunk(ThisWorkbook.Worksheets("Sheet1").Range("a1"), _
lngCols, lngFileNum)
wsExport.Range("a1").Resize(cstChunkSize, lngCols).Value = rngChunk.Value
wsExport.SaveAs "C:\Databases\CSV\NEWEST2_EXPORT_" & lngFileNum & ".csv", xlCSV
wbExport.Close False
Next lngFileNum
Set wbExport = Nothing
Set wsExport = Nothing
Set rngChunk = Nothing
End Sub
Function GetChunk(rngStartPoint As Excel.Range, _
lngColumns As Long, _
lngChunkNumber As Long, _
Optional lngChunkSize As Long = cstChunkSize) As Excel.Range
Dim r As Excel.Range
Set r = rngStartPoint.Offset((lngChunkSize * (lngChunkNumber - 1)))
Set r = r.Resize(lngChunkSize, lngColumns)
Set GetChunk = r
End Function
I want to copy multiple range to another workbook. I have the code below. How can I replace the number 1000 by iLastRow
iLastRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
sh.Range("A3:AG1000, AL3:EJ1000").Select
Selection.Copy
Try the code below, explanation inside the code as comments:
Option Explicit
Sub CopyMultipleRanges()
Dim iLastRow As Long
Dim sh As Worksheet
Dim MultiRng As Range
Set sh = ThisWorkbook.Worksheets("Sheet1") ' <-- change to your sheet's name
With sh
iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
' use the union to set a range combined from multiple ranges
Set MultiRng = Union(.Range("A3:A" & iLastRow), .Range("AL3:EJ" & iLastRow))
End With
' copy the range, there's no need to select it first
MultiRng.Copy
End Sub
Another question is how you want to paste the merged reanges that have a gap in the middle.
The Union method is a solution to this problem. but it also has its cons
The union range should be the same first row and last row.
On the other hand, you can just select the first cell to paste.
you can alway do like this. the main point here is the row number should be the same. here I synchronize both range with the same variable. in your case, change to last cell.
j=1
i = 4
Set MultiRng = Union(Range("A" & j & ":B" & i), Range("D" & j & ":E" & i))
Change Range params from this:
iLastRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
sh.Range("A3:AG1000, AL3:EJ1000").Select
To:
iLastRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
sh.Range("A3:AG" & iLastrow &", AL3:EJ" & iLastRow).Select
Since with multiple selection Copy will not work. You may need to call it twice in your case. (as per suggestion by #YowE3K)
sh.Range("A3:AG" & iLastrow).Select
Selection.Copy
sh.Range("AL3:EJ" & iLastrow).Select
Selection.Copy
Option Explicit
Sub import_APVP()
Dim master As Worksheet, sh As Worksheet
Dim wk As Workbook
Dim strFolderPath As String
Dim selectedFiles As Variant
Dim iFileNum As Integer, iLastRowReport As Integer, iNumberOfRowsToPaste As Integer
Dim strFileName As String
Dim iCurrentLastRow As Integer, iRowStartToPaste As Integer
Dim MultiRng As Range
Dim startTime As Double
getSpeed (True)
Set master = ActiveWorkbook.ActiveSheet
strFolderPath = ActiveWorkbook.Path
ChDrive strFolderPath
ChDir strFolderPath
Application.ScreenUpdating = False
'On Error GoTo NoFileSelected
selectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xlsx*", MultiSelect:=True)
For iFileNum = LBound(selectedFiles) To UBound(selectedFiles)
strFileName = selectedFiles(iFileNum)
Set wk = Workbooks.Open(strFileName)
For Each sh In wk.Sheets
If sh.Name Like "DATA*" Then
With sh
iLastRowReport = .Range("D" & .Rows.Count).End(xlUp).Row
iNumberOfRowsToPaste = iLastRowReport + 2 - 1
'.Range("A3:AG" & iLastRowReport & " , AL3:EJ & iLastRowReport").Select
' Selection.Copy
Set MultiRng = Union(.Range("A3:AG" & iLastRowReport), .Range("AL3:EJ" & iLastRowReport))
'you delete the 3 in range ("AL:EJ....) that make your code not work.
MultiRng.Copy
With master
iCurrentLastRow = .Range("B" & .Rows.Count).End(xlUp).Row
iRowStartToPaste = iCurrentLastRow + 1
'.Activate ' <-- not needed
.Range("A" & iRowStartToPaste).PasteSpecial xlPasteAll
'ActiveSheet.Paste <-- not needed
End With
End With
End If
Next sh
wk.Close
Next
getSpeed (False)
Application.ScreenUpdating = True
NoFileSelected:
End Sub