By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
424,986 Members | 1,944 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 424,986 IT Pros & Developers. It's quick & easy.

need help to activate macro with clearcontents and need to protect sheet

P: 1
May u help us to my code with clearcontent of specific column that need to clear content and protect sheet.Thank you

This is my code
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Sub DownloadFiles()
Call ClearContents

Dim sh As Worksheet, DownloadFolder As String, lastrow As Long, SpecialChar() As String, SpecialCharFound As Double, asdf As Integer, ms As Workbook, digital As Workbook, fdsa As Integer
Dim FilePath As String, i As Long, j As Integer, Result As Long, CountErrors As Long, actvewkb As Workbook, ceel As Excel.Range
Set actvewkb = ActiveWorkbook
Sheets("Schedule").Activate
asdf = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:AT" & asdf).ClearContents

Result = URLDownloadToFile(0, "http:\\theconnection.onsemi.com\manufacturing\osp i\cal_PM\" & _
"production_control\Shop Floor Schedule By Tester\FT_Digital.xlsx", "C:\autodispatch\FT_Digital.xlsx", 0, 0)
Call LastModifiedFile
Set digital = ActiveWorkbook
Range("A11:AT5000").Copy
actvewkb.Activate
Sheets("Schedule").Activate
Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
asdf = Cells(Rows.Count, "A").End(xlUp).Row

Call ForeverLooping(asdf, 0)

Application.DisplayAlerts = False
digital.Close
Application.DisplayAlerts = True

Result = URLDownloadToFile(0, "http:\\theconnection.onsemi.com\manufacturing\osp i\cal_PM\" & _
"production_control\Shop Floor Schedule By Tester\FT_MS.xlsx", "C:\autodispatch\FT_MS.xlsx", 0, 0)

Call LastModifiedFile

Set ms = ActiveWorkbook
Sheets("T2K").Activate
asdf = Cells(Rows.Count, "A").End(xlUp).Row
Range("A10:AT" & asdf).Copy
actvewkb.Activate
Sheets("Schedule").Activate
fdsa = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & fdsa + 1).PasteSpecial xlPasteValuesAndNumberFormats
asdf = Cells(Rows.Count, "A").End(xlUp).Row

Call ForeverLooping(asdf, fdsa)

ms.Activate
Sheets("UFLX").Activate
asdf = Cells(Rows.Count, "A").End(xlUp).Row
Range("A18:AT" & asdf).Copy
actvewkb.Activate
Sheets("Schedule").Activate
fdsa = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & fdsa + 1).PasteSpecial xlPasteValuesAndNumberFormats
asdf = Cells(Rows.Count, "A").End(xlUp).Row
Call ForeverLooping(asdf, fdsa)
Application.DisplayAlerts = False
ms.Close
Application.DisplayAlerts = True

Call FineTuning

Range("A2").Select
End Sub

Sub ClearContents()
Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Sheets("UPDATE").Activate
Range("A4:E" & lastrow).ClearContents
End Sub

Sub ForeverLooping(ByVal asdf As Integer, ByVal i As Integer)
Dim x As Integer
If i = 0 Then i = 2
For x = i To asdf
If Range("A" & x).Text <> "" Then
If Range("A" & x + 1).Text = "" Then
Range("A" & x + 1).EntireRow.Delete
asdf = Cells(Rows.Count, "A").End(xlUp).Row
If x = asdf Then
Exit For
Else
x = x - 1
End If
End If
End If
Next
End Sub

Sub FineTuning()
Dim lastrow As Integer, x As Integer
Dim neValues As Range, neFormulas As Range, MyRange As Range
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lastrow
Range("B" & x).Select
Set MyRange = Columns("B:AT")
On Error Resume Next
Set neValues = Intersect(ActiveCell.EntireRow.SpecialCells(xlCons tants), MyRange)
Set neFormulas = Intersect(ActiveCell.EntireRow.SpecialCells(xlForm ulas), MyRange)
On Error GoTo 0
If neValues Is Nothing And neFormulas Is Nothing Then
Range("B" & x).EntireRow.Delete
End If
Next
End Sub

Public Sub LastModifiedFile()
Dim dirName As String, fName As String, fileTime As Date, fileName As String, latestFile As String
dirName = "C:\autodispatch\"
fName = Dir(dirName & "\*.xlsx*")
latestFile = fName
fileTime = FileDateTime(dirName & fName)
While fName <> ""
If FileDateTime(dirName & fName) > fileTime Then
latestFile = fName
fileTime = FileDateTime(dirName & fName)
End If
fName = Dir()
Wend
If latestFile = "" Then
MsgBox "There are no files in the directory"
Else
Application.DisplayAlerts = False
Workbooks.Open "C:\autodispatch\" & latestFile, UpdateLinks:=xlUpdateLinksAlways
Application.DisplayAlerts = True
End If

x:
If Err.Description <> "" Then MsgBox "Process did not detect the directory. Process will end.", vbCritical, "OEE Report Generator"

End Sub
Jun 28 '18 #1
Share this question for a faster answer!
Share on Google+

Post your reply

Sign in to post your reply or Sign up for a free account.