Ir ao conteúdo
  • Cadastre-se
FlaviaTaynara

Excel Checkbox excel, copiar tabela

Posts recomendados

Ola pessoal.

 

Desculpe usar esse mesmo post, mas minha duvida esta relacionada.
Sou nova no VBA e nao sei nada sobre checkbox, pesquisei em varios sites e tentei varios codigos, porém nenhum funciona como preciso.
Eu tenho um workbook com varias tabs, porém necessiro copiar informações de uma tabela na tab Alert para a mesma tabela na Tab Alert1 somente se a checkbox na coluna L2 estiver selecionada. (posso usar um botao na tab Alert1 para copiar as linhas da tabela que tiver o checkbox selecionado na colina L2).

obrigada
 

 

alert tab.PNG

Alert1 tab.PNG

Compartilhar este post


Link para o post
Compartilhar em outros sites

@FlaviaTaynara dúvida movida para tópico próprio, abraços.

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites
2 horas atrás, FlaviaTaynara disse:

 ... copiar informações de uma tabela na tab Alert para a mesma tabela na Tab Alert1...

 

 

Se entendi corretamente Alert e Alert1 são nomes de duas planilhas, é isso?

Aí você diz que quer copiar de uma tabela e colar na mesma tabela que estaria em outra planilha. 

Não entendi. 🤔

 

Sugestão: disponibilize diretamente aqui no fórum uma amostra do seu arquivo Excel, coloque um exemplo na planilha e coloque também o resultado desejado.

 

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

 

@osvaldomp Infelizmente o meu excel esta restrito e mesmo que coleque o arquivo aqui nao conseguira abrir em outro computador.
sim voce esta correto, Alert  e Alert1 sao os nomes da tab (irei colocar um print melhor). O que quero é copiar as informações que esteja disponivel na tabela da tab Alert (porém apenas se o checkbox estiver selecionado na coluna M (L2)). 
Sinceramente nao sei usar checkbox, nao sei se para isso necessito o form controls ou activeXcontrol. 

 

muito Obrigada.

Alert.PNG

Alert1.PNG

Resultado.PNG

Compartilhar este post


Link para o post
Compartilhar em outros sites

Boa noite @FlaviaTaynara

 

Fiz o que entendi que você deseja, mas sem VBA, utilizando apenas fórmulas.

 

Confira na planilha e dê retorno.

 

Não se esqueça de clicar em Curtir.

 

[]s

25_03_20_Lançar dados na outra planilha conforme caixa de seleção_Patropi.xlsx

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

@osvaldomp consegui anexar o arquivo :) (mas o macro nao aparece, porém ja da para ter uma ideia)

 

 

 

 

@Patropi Bom dia,

 

Muito obrigada pela ajuda.

 

A primeira parte esta funcionando perfeitamente, porém nao consigo corrigir a formula para as informações aparecerem na tabela da aba Alert XX.XX.XXXX (Level 2).

 

eu tentei esta formula.

 

=IFERROR(INDEX(ALERT XX.XX.XXXX!$H$2:$H$7,MATCH(ROW(A1),Clc!$AT$2:$AT$7,0))),'')&''

ROW(A1) nao entendi esta parte da formula.

 

(meu excel esta em inglês normalmente quando tenho " no meu seria ')

 

consegui anexar o excel file (porém o macro nao aparece nenhum...) eu creio que se fosse VBA nao teria problema quando o nome da aba muda. 

 

A aba sempre que clica no botao salvar ira mudar o nome dapara a cada do dia (entao nao sei se isso aferatia as checkbox). 

 

 

muito obrigada pela ajuda

checkbox1.xlsx

Compartilhar este post


Link para o post
Compartilhar em outros sites

 

Experimente:
 

Sub ReplicaDados()
 Dim ws As Worksheet, wsD As Worksheet, chb As CheckBox
  Application.ScreenUpdating = False
  For Each ws In ThisWorkbook.Worksheets
   If ws.Name Like "Alert * (Level 2)" Then
    Set wsD = ws: Exit For
   End If
  Next ws
  wsD.[H2:L6] = ""
 For Each chb In ActiveSheet.CheckBoxes
  If chb.TopLeftCell.Column = 13 And chb = xlOn Then
   Cells(chb.TopLeftCell.Row, 8).Resize(, 5).Copy
   wsD.Cells(Rows.Count, 8).End(3)(2).PasteSpecial xlValues
   'Cells(chb.TopLeftCell.Row, 8).Resize(, 5) = "": chb = xlOff
  End If
 Next chb
 Application.ScreenUpdating = True
End Sub

obs.

1. considerei que ao rodar o código a planilha ativa será a planilha que contém os dados, no seu exemplo a planilha Alert XX.XX.XXXX

2. antes de replicar os dados o código irá limpar o intervalo H2:L6 da planilha destino (Alert XX.XX.XXXX (Level 2)); se você não quiser limpar, então comente ou exclua esta linha do código ~~~> wsD.[H2:L6] = ""

3. se após replicar os dados você quiser limpar as linhas de origem e desmarcar as Caixas de Seleção então (descomente) remova o apóstrofo ínicial desta linha do código ~~~>  'Cells(...

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

@osvaldomp  Muito Obrigada,
 

 

Muito Obrigada, esta funcionando perfeitamente.

 

Eu criei um Botao para iniciar o macro e assign o Macro a ele e esta funcionando perfeitamente. 

 

porém, eu notei que se alguma Checkbox da coluna M (L2) estiver selecionanda quando clico no botao Save File (no alert XX.XX.XXXX (Level 2) ) o mesmo nao funciona (ele salva o arquivo como se fosse a aba Alert XX.XX.XXXX, ou seja ele salva sobre o arquivo que ja estava salvo como o nome (do alerta Data ) sem o (Level 2) no final. 

teria algum motivo para isso? 

 

Ja se nenhuma checkbox estiver selecionada o botao Salve File da aba Alert XX.XX.XXXX (Level 2) funcionando perfeitamente como se deve. 

 

A maneira que os arvivos devem salvar o arquivo quando for clicado:

 

No me do alerta + data (por exemplo o nome do alerta é "Cien")

Se  o botao Save File na aba Alert XX.XX.XXXX for selecionado o arquivo sera automaticamente salvo como:  Cien 03.26.2020 

Se  o botao Save File na aba Alert XX.XX.XXXX (Level 2) for selecionado o arquivo sera automaticamente salvo como: Cien 03.26.2020  (Level 2)

 

Seria possivel por uma linha no codigo para que se a checkbox esteja ou nao selecionada  nao afete na hora que o save file botao do Alert XX.XX.XXXX (Level 2) seja selecionado?

 

 

Obrigada pelo seu tempo. 

 

 

 

Compartilhar este post


Link para o post
Compartilhar em outros sites
1 hora atrás, FlaviaTaynara disse:

porém, eu notei que se alguma Checkbox da coluna M (L2) estiver selecionanda ... sem o (Level 2) no final. 

teria algum motivo para isso? 

Ja se nenhuma checkbox estiver selecionada o botao Salve File da aba Alert XX.XX.XXXX (Level 2) funcionando perfeitamente como se deve. 

Não vejo qualquer interferência ou relação entre o código que passei e o salvamento do arquivo.

 

Seria possivel por uma linha no codigo para que se a checkbox esteja ou nao selecionada  nao afete na hora que o save file botao do Alert XX.XX.XXXX (Level 2) seja selecionado?

A sua ideia é acrescentar uma linha a qual código? Se for ao código que passei, não faz sentido. Se for aos seus códigos que fazem o salvamento então precisamos ver os códigos.

 

 

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

@osvaldomp Bom dia,

 

Tens razao, teu codigo esta funcionando perfeitamente.


Notei que nao tem relação se a checkbox estiver selecionado ou nao, o Botao de Save File da aba Alert XX.XX.XXXX (Level 2) nao funciona quando o file ja salvo no Alert XX.XX.XXXX e é aberto novamente pelo time do Level 2 e ao tentar salvar o mesmo usando o Save File no Alert XX.XX.XXXX (Level 2).  (porém isso é exatamente o que preciso corrigir, pois o time do Level 2 usa o arquivo salvo pelo Alert XX.XX.XXXX para fazer as mudancas necessarias e salva como um novo aquivo).

 

Este codigo é o praticamente o mesmo para o botao Salve File no Alert XX.XX.XXXX

preciso modificar umas coisas (como informações que se deve aparecer no closing note), porém essas mudancas nao irao interferir com o Botao salvar.  

 

Talvez tu consegue ver onde esta meu erro e o por que se uso o arquivo do excel ja salvo (ja com o nome alterado ex: Cien 03.26.2020  o mesmo noa pode ser salvo como um novo arquivo alterando o nome como se é esperado ex: Cien 03.26.2020  (Level 2) ??

 

mais uma vez muito obrigada.

'Salve Fale na Aba Alert XX.XX.XXXX 

Sub SaveFile()
Dim ws As Worksheet
Call RemLink
If ClientReview.Visible = True Then
Set Client = ClientReview
Else

 For Each ws In ActiveWorkbook.Worksheets
    If ws.Name Like "Client Review*" Then
     Set Client = ws
     
     End If
 Next ws
End If

If CheckForPics = False Then Exit Sub

If CalculationSheet.Range("AP1").Value = True Or CalculationSheet.Range("AP2").Value = True Or CalculationSheet.Range("AP3").Value = True Or CalculationSheet.Range("AP4").Value = True Or CalculationSheet.Range("AP5").Value = True Then
    If CheckforWC = False Then Exit Sub
End If

If NotFilled = False Then Exit Sub
If NotFilledRules = False Then Exit Sub
If NotFilledClient = False Then Exit Sub

If Client.Range("H1").Value <> "" Then
        If CalculationSheet.Range("AP6").Value = True Then
        Debug.Print "Works"
      If CheckForClientWC = False Then Exit Sub
    End If
    If CheckForClientNegative = False Then Exit Sub
    
    
  End If
Alert.Cells.CheckSpelling
ClientReview.Cells.CheckSpelling

If Application.ActiveWorkbook.Path = Environ("userprofile") & "\Desktop\Investigations" Then
 ActiveWorkbook.Save
 MsgBox " File has been saved successfully."
 Exit Sub
End If

ClientReview.Activate
today = Format(Date, "MM.DD.YYYY")
Range("C6").Value = today

savePath = Environ("userprofile") 'get unique path for every user
CompanyName = ThisWorkbook.Sheets(1).Range("C1").Value
CompanyName = Replace(CompanyName, "&", "")
CompanyName = Replace(CompanyName, "/", "")
CompanyName = Replace(CompanyName, "\", "")
CompanyName = Replace(CompanyName, ":", "")
CompanyName = Replace(CompanyName, "*", "")
CompanyName = Replace(CompanyName, "?", "")
CompanyName = Replace(CompanyName, Chr(34), "")
CompanyName = Replace(CompanyName, "<", "")
CompanyName = Replace(CompanyName, ">", "")
CompanyName = Replace(CompanyName, "|", "")

UserName = Application.UserName
Alert.Visible = xlSheetVisible
Alert.Activate
Range("C1").Value = UserName
Alert.Name = "Alert " & today

If Len(Dir(savePath & "\Desktop\Investigations", vbDirectory)) = 0 Then
   MkDir (savePath & "\Desktop\Investigations")
End If

On Error GoTo ErrorMessage
    ActiveWorkbook.SaveCopyAs Filename:=savePath & "\Desktop\Investigations\" & CompanyName & " " & today & ".xls"

    MsgBox "File has been successfully saved to investigations folder in user's desktop."
Exit Sub



ErrorMessage:
MsgBox "Something went wrong, file not saved!"
End Sub

Sub SaveFileWithoutAlertTab()
Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False 'For less lag
Call RemLink
        If CalculationSheet.Range("AP6").Value = True Then
      If CheckForClientWC = False Then Exit Sub
    End If
    If CheckForClientNegative = False Then Exit Sub
    If NotFilledClient = False Then Exit Sub
    ClientReview.Cells.CheckSpelling



ClientReview.Activate
today = Format(Date, "MM.DD.YYYY")
Range("C6").Value = today

savePath = Environ("userprofile") 'get unique path for every user
CompanyName = ThisWorkbook.Sheets(1).Range("C1").Value
CompanyName = Replace(CompanyName, "&", "")
CompanyName = Replace(CompanyName, "/", "")
CompanyName = Replace(CompanyName, "\", "")
CompanyName = Replace(CompanyName, ":", "")
CompanyName = Replace(CompanyName, "*", "")
CompanyName = Replace(CompanyName, "?", "")
CompanyName = Replace(CompanyName, Chr(34), "")
CompanyName = Replace(CompanyName, "<", "")
CompanyName = Replace(CompanyName, ">", "")
CompanyName = Replace(CompanyName, "|", "")
UserName = Application.UserName

If Len(Dir(savePath & "\Desktop\Investigations", vbDirectory)) = 0 Then
   MkDir (savePath & "\Desktop\Investigations")
End If

Alert.Visible = xlSheetVeryHidden

On Error GoTo ErrorMessage
    ActiveWorkbook.SaveCopyAs Filename:=savePath & "\Desktop\Investigations\" & CompanyName & " " & today & ".xls"

Alert.Visible = xlSheetVisible
Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True
MsgBox "File has been successfully saved to investigations folder in user's desktop."
Exit Sub

ErrorMessage:
MsgBox "Something went wrong, file not saved!"


End Sub


Sub CopyPasteFromDownloadedClientReviewSheet()

Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False 'For less lag

ClientReviewTabIsHided = False
ClientReview.Visible = xlSheetVeryHidden
ClientReview.Name = "Original Client Review"

On Error GoTo ErrorTrue
Worksheets(1).Activate
Dim ws As Worksheet
Dim DownloadedClientReviewSheet As Worksheet
today = Format(Date, "MM.DD.YYYY")
For Each ws In ThisWorkbook.Worksheets
    
    ws.Activate
    If ws.Name Like "Client Review*" Then
        Set DownloadedClientReviewSheet = ActiveSheet
        DownloadedClientReviewSheet.Name = "Client Review" & " " & today
        GoSub CopyPasteFromDownloadedClientReview
        Exit For
    End If
    
Next ws

CopyPasteFromDownloadedClientReview:

Range("C1:C2").Select
Selection.Copy
Alert.Activate
Range("C2").PasteSpecial xlPasteValues
'Unmerge client summary in Alert sheet to make it available for pasting
'Range("K16").UnMerge

'DownloadedClientReviewSheet.Activate
'DownloadedClientReviewSheet.Range("H1:H2").Value = ""
'Range("J3:L8").UnMerge
'Range("J3").Copy
'Alert.Activate
'Range("K16").PasteSpecial xlPasteValues
'Range("K16:Q22").Merge
'DownloadedClientReviewSheet.Activate
Alert.Range("K16").Value = "='" & DownloadedClientReviewSheet.Name & "'!J3"
'Range("J3:L8").Merge
'Alert.Activate

ClientReviewTabIsHided = True

Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True

Exit Sub
ErrorTrue:
ClientReview.Visible = xlSheetVisible
ClientReview.Name = "Client Review"
Alert.Activate
Range("K16:Q22").Merge
MsgBox "No manually added sheets identified."
End Sub

Sub ClearAll()

Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False 'For less lag

'Delete all pictures
Dim Sh As Shape
Dim sheetnumber As Integer
Dim ws As Worksheet
Dim starting_ws As Worksheet

VBanswer = MsgBox("Do you want to refresh the template?", vbYesNo, "Refresh Template")

If VBanswer = vbYes Then
    GoSub ClearOut
Else
    Exit Sub
End If

ClearOut:

Alert.Visible = xlSheetVisible
Alert.Name = "Alert XX.XX.XXXX"

ClientReview.Visible = xlSheetVisible
ClientReview.Name = "Client Review"

Worksheets(1).Select
Set starting_ws = ActiveSheet

For Each ws In ThisWorkbook.Worksheets

    ws.Activate
    If ws.Name <> "Client Review" And ws.Name <> "Alert XX.XX.XXXX" And ws.Name <> "Closing Notes" And ws.Name <> "EmailData" And ws.Name <> "Red Flags" And ws.Name <> "AutoRules" And ws.Name <> "PivotBene" And ws.Name <> "Version Control" And ws.Name <> "Clc" And ws.Name <> "Countries" And ws.Name <> "Transaction Details" And ws.Name <> "Pivot" And ws.Name <> "Business Rule Justifications" And ws.Name <> "12 Months" And ws.Name <> "RFI Submition Contacts" And ws.Name <> "RFI Questions" And ws.Name <> "Exceptions" And ws.Name <> "12_Months_Pivot" Then
        ActiveSheet.Delete
    End If

Next

'Dim wbBook As Workbook
'Dim nName As Name

'Set wbBook = ActiveWorkbook

'For Each nName In wbBook.Names
'nName.Delete
'Next nName


For sheetnumber = 1 To Sheets.count
    For Each Sh In Sheets(sheetnumber).Shapes
        If Sh.Type = msoPicture Then Sh.Delete
    Next
Next sheetnumber

'clear named ranges



'CLIENT REVIEW TAB
Sheets("Client Review").Activate
Range("C1:C3").Value = ""
Range("C6").Value = ""
Range("H1:H2").Value = ""
Range("G8:H12").Value = ""
Range("J3").Value = "The client has been with WUBS since XXX and has been incorporated since MMDDYY. The expected average transaction volume in currency is YYY and the expected average frequency is ZZZ payments YXX. The client transacts with the following location(s) XXX. The client [ClientDescription] and intends to use WUBS for [PayPurpose]. Further information is located in client's Sales Force profile."

'comments
Sheets("Client Review").Range("C214:G217").Value = ""
Sheets("Client Review").Range("C150:G153").Value = ""
Sheets("Client Review").Range("C108:G111").Value = ""
Sheets("Client Review").Range("g59:G65").Value = ""

Range("C59:F59").FormulaR1C1 = "=IF(R[-51]C[4]<>"""",R[-51]C[4],""UBO 1"")"
Range("C60:F60").FormulaR1C1 = "=IF(R[-51]C[4]<>"""",R[-51]C[4],""UBO 2"")"
Range("C61:F61").FormulaR1C1 = "=IF(R[-51]C[4]<>"""",R[-51]C[4],""UBO 3"")"
Range("C62:F62").FormulaR1C1 = "=IF(R[-51]C[4]<>"""",R[-51]C[4],""UBO 4"")"
Range("C63:F63").FormulaR1C1 = "=IF(R[-51]C[4]<>"""",R[-51]C[4],""UBO 5"")"
Range("C64:F64").FormulaR1C1 = "=IF(R[-63]C[5]<>"""",R[-63]C[5],""Client name for search"")"
Range("C65:F65").FormulaR1C1 = "=IF(R[-63]C[5]<>"""",R[-63]C[5],""Trading name for search"")"


'ALERT TAB
Alert.Activate
Range("C1").Value = ""
Range("H2:L6").Value = ""
Range("O2").Value = ""
Range("B16").Value = CalculationSheet.Range("Default_Closing_Notes").Value

Range("K16:Q22").Merge

Range("C2").FormulaR1C1 = "=IF('Client Review'!R[-1]C<>"""",'Client Review'!R[-1]C,"""")"
Range("C3").FormulaR1C1 = "=IF('Client Review'!R[-1]C<>"""",'Client Review'!R[-1]C,"""")"
Range("K16").FormulaR1C1 = "='Client Review'!R[-13]C[-1]"


Range("C66").FormulaR1C1 = "=IF(R[-64]C[5]<>"""",R[-64]C[5],""Bene 1"")"
Range("C67").FormulaR1C1 = "=IF(R[-64]C[5]<>"""",R[-64]C[5],""Bene 2"")"
Range("C68").FormulaR1C1 = "=IF(R[-64]C[5]<>"""",R[-64]C[5],""Bene 3"")"
Range("C69").FormulaR1C1 = "=IF(R[-64]C[5]<>"""",R[-64]C[5],""Bene 4"")"
Range("C70").FormulaR1C1 = "=IF(R[-64]C[5]<>"""",R[-64]C[5],""Bene 5"")"


'Delete all comments
Alert.Range("C318:G321").Value = ""
Alert.Range("C270:G273").Value = ""
Alert.Range("C230:G233").Value = ""
Alert.Range("C189:G192").Value = ""
Alert.Range("C148:G151").Value = ""
Alert.Range("C107:G110").Value = ""
Alert.Range("G66:G70").Value = ""
Countries.Visible = False
Grid.Visible = False
Pivot.Visible = False
CalculationSheet.Visible = False
Avarage.Visible = False
PivotBene.Visible = False
AutoRules.Visible = False
RedFlagss.Visible = False


ClientReview.Range("C23").Value = ""

CalculationSheet.Range("B100:B121").Value = "FALSE"
CalculationSheet.Range("OutTransactionsStartDate").Value = "XXZ"
CalculationSheet.Range("OutTransactionsEndDate").Value = "YYX"
CalculationSheet.Range("broken_rules").Value = "ZZX"
CalculationSheet.Range("rules_count").Value = ""


CalculationSheet.Range("BeneficiaryInfoFromTable").Value = CalculationSheet.Range("K7").Value
CalculationSheet.Rows("150:" & Rows.count).ClearContents
CalculationSheet.Range("RulesForWhiteListing").Value = ""
CalculationSheet.Range("RuleCountToWhiteList").Value = ""
CalculationSheet.Range("RulesJustification").Value = CalculationSheet.Range("K9").Value
CalculationSheet.Range("Ending").Value = CalculationSheet.Range("K3").Value
CalculationSheet.Range("redflags").Value = CalculationSheet.Range("K5").Value
CalculationSheet.Range("Benecc").Value = "XXX"
CalculationSheet.Range("C6").Value = ""
CalculationSheet.Range("AP1:AP6").Value = "False"
ClientReview.Range("D67").Value = ""

EmailData.Cells.Clear
Pivot.Cells.Clear
Grid.Cells.Clear
Avarage.Cells.Clear
Alert.Range("P2").Value = ""

Alert.Range("D32").Value = ""
CalculationSheet.Range("I2:I" & CalculationSheet.Cells(Rows.count, 9).End(xlUp).Row).Value = ""


ClientReview.Range("C67").Value = ""
ClientReview.Range("D67").Value = ""
ClientReview.Range("C114").Value = ""
CalculationSheet.Range("C3:H30").Value = ""
avarage_pivot.Visible = False

On Error Resume Next
PivotBene.PivotTables("BeneNames").TableRange2.Clear
On Error GoTo 0

On Error Resume Next
ActiveWorkbook.SlicerCaches("Slicer_Bene_Names").Delete
On Error GoTo 0

On Error Resume Next
ActiveWorkbook.SlicerCaches("Slicer_Dates").Delete
On Error GoTo 0

On Error Resume Next
ActiveWorkbook.SlicerCaches("Slicer_Bene_Name").Delete
On Error GoTo 0

On Error Resume Next
ActiveWorkbook.SlicerCaches("Slicer_Bene_Name1").Delete
On Error GoTo 0

AutoRules.Range("E2:Z50").Clear

PivotBene.Rows("2:" & Rows.count).ClearContents
avarage_pivot.Rows.Delete
Application.GoTo Reference:=Range("a1"), Scroll:=True
Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True


MsgBox "Template has been refreshed.", vbOKOnly, "Information"

End Sub


Private Sub Workbook_Open()

Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False

Dim openPath, FilePath As String
Dim data_file As Workbook

    Set WBMain = ThisWorkbook
    
    openPath = Environ("userprofile")
    FilePath = (openPath & "\Box\WUBS GAI & SAR REPORTING\Distribution lists (IRIS TMS case, World-Check, Fintrac)\Distribution WU WAY\Data for Templates.xlsx")
    
    If CalculationSheet.Range("A25").Value <> FileDateTime(FilePath) Then
        exceptions.Rows.Clear
        rfi_contacts.Rows.Clear
        rfi_questions.Rows.Clear
        Set data_file = Workbooks.Open(openPath & "\Box\WUBS GAI & SAR REPORTING\Distribution lists (IRIS TMS case, World-Check, Fintrac)\Distribution WU WAY\Data for Templates.xlsx")
        data_file.Sheets("RFI Submition Contacts").Range("A:M").Copy rfi_contacts.Range("A1")
        data_file.Sheets("RFI Questions").Range("A:C").Copy rfi_questions.Range("A1")
        data_file.Sheets("Rule Exceptions").Range("A:C").Copy exceptions.Range("A1")
        data_file.Close
        CalculationSheet.Range("A25").Value = FileDateTime(FilePath)
    End If
    
    


Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True


End Sub

--
-----------
--

'Salve File na Aba Alert XX.XX.XXXX (Level 2)


Option Explicit

Sub Save_Level_2_File()
Dim ws As Worksheet
Dim Client As ClientReview

Call RemLink2
If ClientReview.Visible = True Then
Set Client = ClientReview
Else

 For Each ws In ActiveWorkbook.Worksheets
    If ws.Name Like "Client Review*" Then
     Set Client = ws
     
     End If
 Next ws
End If

If CheckForPics2 = False Then Exit Sub

If CalculationSheet.Range("AR1").Value = True Or CalculationSheet.Range("AR2").Value = True Or CalculationSheet.Range("AR3").Value = True Or CalculationSheet.Range("AR4").Value = True Or CalculationSheet.Range("AR5").Value = True Then
    If CheckforWC = False Then Exit Sub
End If

If NotFilled = False Then Exit Sub
If NotFilledRules = False Then Exit Sub
If NotFilledClient = False Then Exit Sub

If Client.Range("H1").Value <> "" Then
        If CalculationSheet.Range("AR6").Value = True Then
        Debug.Print "Works"
      If CheckForClientWC = False Then Exit Sub
    End If
    If CheckForClientNegative = False Then Exit Sub
    
    
  End If
Alert1.Cells.CheckSpelling
ClientReview.Cells.CheckSpelling

If Application.ActiveWorkbook.Path = Environ("userprofile") & "\Desktop\Investigations" Then
 ActiveWorkbook.Save
 MsgBox " File has been saved successfully."
 Exit Sub
End If

Dim today As String
Dim savePath As String
Dim CompanyName As String
Dim UserName As String

ClientReview.Activate
today = Format(Date, "MM.DD.YYYY")
Range("C6").Value = today

savePath = Environ("userprofile") 'get unique path for every user
CompanyName = ThisWorkbook.Sheets(1).Range("C1").Value
CompanyName = Replace(CompanyName, "&", "")
CompanyName = Replace(CompanyName, "/", "")
CompanyName = Replace(CompanyName, "\", "")
CompanyName = Replace(CompanyName, ":", "")
CompanyName = Replace(CompanyName, "*", "")
CompanyName = Replace(CompanyName, "?", "")
CompanyName = Replace(CompanyName, Chr(34), "")
CompanyName = Replace(CompanyName, "<", "")
CompanyName = Replace(CompanyName, ">", "")
CompanyName = Replace(CompanyName, "|", "")

UserName = Application.UserName
Alert1.Visible = xlSheetVisible
Alert1.Activate
Range("C1").Value = UserName
Alert1.Name = "Alert " & today & " (Level 2)" ' button save file Level 2

If Len(Dir(savePath & "\Desktop\Investigations", vbDirectory)) = 0 Then
   MkDir (savePath & "\Desktop\Investigations")
End If

On Error GoTo ErrorMessage
    ActiveWorkbook.SaveCopyAs Filename:=savePath & "\Desktop\Investigations\" & CompanyName & " " & today & " (Level 2)" & ".xls"

    MsgBox "File has been successfully saved to investigations folder in user's desktop."
Exit Sub



ErrorMessage:
MsgBox "Something went wrong, file not saved!"
End Sub

Sub CopyPasteFromDownloadedClientReviewSheet()

Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False 'For less lag

ClientReviewTabIsHided = False
ClientReview.Visible = xlSheetVeryHidden
ClientReview.Name = "Original Client Review"

On Error GoTo ErrorTrue
Worksheets(1).Activate
Dim ws As Worksheet
Dim DownloadedClientReviewSheet As Worksheet
today = Format(Date, "MM.DD.YYYY")
For Each ws In ThisWorkbook.Worksheets
    
    ws.Activate
    If ws.Name Like "Client Review*" Then
        Set DownloadedClientReviewSheet = ActiveSheet
        DownloadedClientReviewSheet.Name = "Client Review" & " " & today & "" & "(Level 2)"
        GoSub CopyPasteFromDownloadedClientReview
        Exit For
    End If
    
Next ws

CopyPasteFromDownloadedClientReview:

Range("C1:C2").Select
Selection.Copy
Alert1.Activate
Range("C2").PasteSpecial xlPasteValues
'Unmerge client summary in Alert sheet to make it available for pasting
'Range("K16").UnMerge

'DownloadedClientReviewSheet.Activate
'DownloadedClientReviewSheet.Range("H1:H2").Value = ""
'Range("J3:L8").UnMerge
'Range("J3").Copy
'Alert.Activate
'Range("K16").PasteSpecial xlPasteValues
'Range("K16:Q22").Merge
'DownloadedClientReviewSheet.Activate
Alert.Range("K16").Value = "='" & DownloadedClientReviewSheet.Name & "'!J3"
'Range("J3:L8").Merge
'Alert.Activate

ClientReviewTabIsHided = True

Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True

Exit Sub
ErrorTrue:
ClientReview.Visible = xlSheetVisible
ClientReview.Name = "Client Review"
Alert.Activate
Range("K16:Q22").Merge
MsgBox "No manually added sheets identified."
End Sub

Sub RemLink2() 'Excel VBA remove links from workbook.
Dim ar As Variant
Dim i As Integer

ar = ActiveWorkbook.LinkSources(1)

On Error Resume Next 'Trap error

For i = 1 To UBound(ar) 'Excel VBA loop throuh links
ActiveWorkbook.BreakLink ar(i), xlLinkTypeExcelLinks
Next i

On Error GoTo 0

End Sub

Function CheckForPics2() As Boolean

Dim ReturnValue As Boolean
Dim nm As String
Dim picBox As Integer
Dim i As Long
Dim tnm As String
CheckForPics2 = True

For i = 2 To 6
If Range("H" & i).Value <> "" Then
picBox = i
ReturnValue = CheckPic2(picBox)

Dim result As String

  If ReturnValue = False Then
  tnm = CalculationSheet.Range("W" & i).Value
  result = MsgBox("No screenshots for " & tnm & " were found." & vbNewLine & "Do you still want to save file?", vbYesNo + vbQuestion + vbDefaultButton2)
     If result = vbNo Then
     CheckForPics2 = False
     Exit For
     Else: CheckForPics2 = True
     End If
     Else: CheckForPics2 = True
     
  End If
Else
Exit For

End If

Next i

End Function

Function CheckPic2(xRg As Integer) As Boolean

Dim Client As Object

Dim xpicRg As Range
Dim nRg As String
Dim nRg1 As Integer
Dim nRg2 As Integer
Dim ws As Worksheet
If ClientReview.Visible = True Then
Set Client = ClientReview
Else

 For Each ws In ActiveWorkbook.Worksheets
    If ws.Name Like "Client Review*" Then
     Set Client = ws
     
     End If
 Next ws
End If


If xRg < 7 Then
Alert1.Activate
Else

Client.Activate


End If
nRg = CalculationSheet.Range("V" & xRg).Value
nRg1 = Split(nRg, ":")(0)
nRg2 = Split(nRg, ":")(1)
Debug.Print "ngr1: " & nRg1
Debug.Print "nrg2: " & nRg2

Dim xPic As Object

For Each xPic In ActiveSheet.Pictures
    Debug.Print "xPic: " & xPic.TopLeftCell.Row
    If xPic.TopLeftCell.Row >= nRg1 And xPic.TopLeftCell.Row <= nRg2 Then
    Debug.Print "Ok"
    CheckPic2 = True
    Exit For

    Else
    CheckPic2 = False
    End If
Next


End Function

Function NotFilled2() As Boolean

Dim vl As String
Dim Mnm As String
Dim spos As Long
Dim i As Integer
Dim lenghts As Integer
Dim result As Integer


For i = 2 To 10
vl = CalculationSheet.Range("Z" & i).Value
Mnm = CalculationSheet.Range("AA" & i).Value

If InStr(Alert1.Range("B16").Value, vl) Then
Alert1.Activate
Alert1.Range("B16").Select
spos = InStr(Alert1.Range("B16").Value, vl)
lenghts = Len(vl)
Alert1.Range("B16").Characters(Start:=spos, Length:=lenghts).Font.ColorIndex = 3
Alert1.Range("B16").Characters(Start:=spos, Length:=lenghts).Font.Bold = True
result = MsgBox(Mnm & " was not entered in Closing Notes." & vbNewLine & "Do you still want to save file?", vbYesNo + vbQuestion + vbDefaultButton2)

If result = vbYes Then
NotFilled2 = True
Else
NotFilled2 = False
Exit For


End If

Else: NotFilled2 = True


End If


Next i


End Function



 

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

Sugestão: esqueça por um momento esses quilômetros de códigos e nos diga exatamente o que você quer fazer ao salvar o arquivo. Assim, poderemos tentar elaborar um código, pois revisar os códigos que você postou aí acima é tarefa insana.:tw_cry:

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites
1 hora atrás, osvaldomp disse:

Sugestão: esqueça por um momento esses quilômetros de códigos e nos diga exatamente o que você quer fazer ao salvar o arquivo. Assim, poderemos tentar elaborar um código, pois revisar os códigos que você postou aí acima é tarefa insana.:tw_cry:

Desculpa acabei me empolgando. 

 

Neste momento estou revisando o codigo do Salve File da aba Alert XX.XX.XXXX (Level 2) que esta do modulo Level_2 e ja anotei varias partes que pode ser deletada.

O que eu preciso é:

 

Que quando o botao Save File da aba Alert XX.XX.XXXX (Level 2) funcione salvando um novo arquivo com mesmo nome apenas acrescentando (Level 2) na frente ex:

CCISD 03.26.2020 (o botao save file na aba Alert XX.XX.XXXX criou este arquivo quando foi selecionado).

O time do level 2 ira usar este arquivo criado por ele e fazer suas anotacoes na Aba do Level 2 e ira salvar novamente, pore neste momento usando o botao Save File disponivel na Aba Alert XX.XX.XXXX (Level 2) e o novo arquivo tera o nome de ex:

CCISD 03.27.2020 (Level 2).

 

 

preciso fazer como um novo arquivo com o mesmo nome que o anterior so acrescentando (Level 2 a frente) e chegar. 

 

 

Sub Save_Level_2_File()
Dim ws As Worksheet
Dim Client As ClientReview

Alert1.Cells.CheckSpelling
ClientReview.Cells.CheckSpelling

If Application.ActiveWorkbook.Path = Environ("userprofile") & "\Desktop\Investigations" Then
 ActiveWorkbook.Save
 MsgBox " File has been saved successfully."
 Exit Sub
End If

Dim today As String
Dim savePath As String
Dim CompanyName As String
Dim UserName As String

ClientReview.Activate
today = Format(Date, "MM.DD.YYYY")
Range("C6").Value = today

savePath = Environ("userprofile") 'get unique path for every user
CompanyName = ThisWorkbook.Sheets(1).Range("C1").Value
CompanyName = Replace(CompanyName, "&", "")
CompanyName = Replace(CompanyName, "/", "")
CompanyName = Replace(CompanyName, "\", "")
CompanyName = Replace(CompanyName, ":", "")
CompanyName = Replace(CompanyName, "*", "")
CompanyName = Replace(CompanyName, "?", "")
CompanyName = Replace(CompanyName, Chr(34), "")
CompanyName = Replace(CompanyName, "<", "")
CompanyName = Replace(CompanyName, ">", "")
CompanyName = Replace(CompanyName, "|", "")

UserName = Application.UserName
Alert1.Visible = xlSheetVisible
Alert1.Activate
Range("C1").Value = UserName
Alert1.Name = "Alert " & today & " (Level 2)" ' button save file Level 2

If Len(Dir(savePath & "\Desktop\Investigations", vbDirectory)) = 0 Then
   MkDir (savePath & "\Desktop\Investigations")
End If

On Error GoTo ErrorMessage
    ActiveWorkbook.SaveCopyAs Filename:=savePath & "\Desktop\Investigations\" & CompanyName & " " & today & " (Level 2)" & ".xls"

    MsgBox "File has been successfully saved to investigations folder in user's desktop."
Exit Sub



ErrorMessage:
MsgBox "Something went wrong, file not saved!"
End Sub

 

CCISD 03.26.2020.xlsx

adicionado 27 minutos depois

@osvaldomp Ah esqueci de mencionar que o nome do arquivo é baseado no nome do Client name for search (Na coluna C linha 1) que se encontra na aba Client Review.

Compartilhar este post


Link para o post
Compartilhar em outros sites

Experimente:

Sub SalvaComo()
 Application.DisplayAlerts = False
 If ActiveSheet.Name Like "*(Level 2)" Then
  ThisWorkbook.SaveAs Filename:=Sheets("Client Review").[C1] & " " & Format(Date, "mm.dd.yyyy") & " (Level 2).xlsm"
 Else: ThisWorkbook.SaveAs Filename:=Sheets("Client Review").[C1] & " " & Format(Date, "mm.dd.yyyy") & ".xlsm"
 End If
End Sub

obs.

1. vincule ao código acima os botões Save File tanto da planilha Alert como da planilha Alert (Level 2)

2. antes de rodar o código pela primeira vez o arquivo atual deverá estar salvo (com qualquer nome)

3. o novo arquivo será salvo na mesma pasta do arquivo atual

4. ao clicar no botão da planilha Alert o novo arquivo será salvo como ~~~> Client Review!C1 & data atual mm.dd.aaaa, então se salvar o arquivo hoje (27/mar/20) o nome será CCISD 03.27.2020

5. ao clicar no botão na planilha Alert (Level 2) o arquivo será salvo como ~~~> Client Review!C1 & data atual mm.dd.aaaa & (Level 2), então se salvar o arquivo hoje (27/mar/20) o nome será CCISD 03.27.2020 (Level 2)

  • Curtir 2

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora





Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×
×
  • Criar novo...

montagem2018-capa-newsletter2.jpg

PROMOÇÃO DE QUARENTENA

De R$ 39,90 por apenas R$ 19,90 só até as 23h59min desta sexta-feira 27/12/2020

CLIQUE AQUI E COMPRE AGORA MESMO!