Posts by Bill Rockenbach

Bill Rockenbach · Feb 9th 2014

Re: copy data to new sheet based on condition

This procedure will run each time a catalog Multiple is changed. It clears the invoice items and rebuilds them with each change.

Put it in the Catalog module. To clear the invoice simply clear the Catalog multiple column. To remove an item change the Catalog multiple to zero or null.

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range


    If Target.Column = 7 Then
        Sheet5.Range("B25:F40").ClearContents


        For Each c In Range("G2", Cells(Rows.Count, "G").End(xlUp))


            If c = 0 Then c = ""
        
            If c <> 0 Then
                With Sheets("Invoice")
                    .Range("B40").End(xlUp).Offset(1, 0) = c.Offset(, -3)
                    .Range("D40").End(xlUp).Offset(1, 0) = c.Offset(, -2)
                    .Range("E40").End(xlUp).Offset(1, 0) = c
                    .Range("F40").End(xlUp).Offset(1, 0) = c.Offset(, 1)
                End With
            End If


        Next c
    End If


End Sub

Display More

Bill Rockenbach · Aug 21st 2013

Re: Copying non continuous cell to one single row in another sheet

Yes, it is possible.

Bill Rockenbach · Aug 20th 2013

Re: Copying non continuous cell to one single row in another sheet

No need to activate the master sheet if you do not need to copy the formats

Insert this code in your loop through the files

Code

Dim From
    Dim i As Integer
    Dim NextR As Long


    From = Array(Range("B3"), Range("B9"), Range("F2"), Range("F15"), Range("F17"), Range("B42"))


    With Workbooks("Análise Campanha Safrinha 14_01_Ago_13 Oficial.xlsm").Sheets("Safrinha Preco_Normal 14")


        NextR = .Cells(Rows.Count, "A").End(xlUp).Row + 1


        For i = 0 To 5
            .Cells(NextR, i + 1) = From(i)
        Next i


    End With

Display More

Bill Rockenbach · Aug 20th 2013

Re: Hidden VBA code

Smallman,
Your PM box is full. I can not respond to your PM

Bill Rockenbach · Aug 20th 2013

Re: Hidden VBA code

Thank you all for your comments.

Duh! How did I miss that?

Other products of Simple Planning use Amortization Schedules. This schedules use many “If” formulas to display the schedule when a parameter of the loan changes. Again no vba code. They also use index formulas to change the data presented in some of their Dashboard charts.

Bill Rockenbach · Aug 20th 2013

I ran across an Excel .xls application wherein the worksheets have forms control command buttons and list boxes with functioning code and cells with active events.

But none of the code appears in the VBA project. The only thing that shows in the VBA Project is a list of the worksheet names in the Project Explorer. There are no standard modules, class modules nor userforms. All code is hidden, yet the VBA project is not locked or protected. There are no associated com .dll’s and when the file is opened the security warning about macros does not display.

Anyone know how the code is being hidden?

The sample demo file can be downloaded from Simple Planning.

(I am not associated with this website, nor have any opinion about their software.)

Bill Rockenbach · Aug 15th 2013

Re: VBA Form, find last row and fill

Please use code tags on all vba code. I added code tags to your post

Try this solution . . .

Code

With Sheet2
    
        .Select


        i = .Cells(Rows.Count, "A").End(xlUp).Row + 1


        .Range("A" & i & ":T" & i) = Array(TextBox15.Text, TextBox3.Text, TextBox1.Text, TextBox2.Text, _
                                           TextBox19.Text, TextBox4.Text, TextBox16.Text, ComboBox1.Text, "AOSTE ID: " & TextBox7.Text, "OTC :" & TextBox5.Text, "MRC: " & TextBox6.Text, TextBox17.Text, TextBox18.Text, TextBox8.Text, _
                                           TextBox9.Text, TextBox10.Text, TextBox11.Text, TextBox12.Text, TextBox13.Text, TextBox14.Text)
        '.Range("A" & i & ":AJ" & i).Borders.LineStyle = xlContinuous 'not needed if prior cells have borders
        
        'copy prior row conditional format
        .Range("A" & i - 1 & ":T" & i - 1).Copy
        .Cells(i, 1).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                               SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False


    End With

Display More

Bill Rockenbach · Aug 13th 2013

Re: Before Close Event to save changes to Another Workbook

One more time. . .

Code

Sub Macro1()
    If ThisWorkbook.Name <> "Master.xlsm" Then
        Application.DisplayAlerts = False
        Sheets("Sheet2").Activate
        Sheets("Sheet2").Columns("D:D").Select
        Selection.Copy
        Workbooks.Open ThisWorkbook.Path & "\Master.xlsm"
        With Workbooks("Master.xlsm")
            .Sheets("Sheet2").Activate
            .Sheets("Sheet2").Columns("D:D").Select
            .ActiveSheet.Paste
            .ActiveSheet.Range("A1").Select
            .Sheets("Sheet1").Select
            .Close savechanges:=True
        End With
        Sheets("Sheet1").Select
        Application.DisplayAlerts = True
    End If
End Sub

Display More

Bill Rockenbach · Aug 12th 2013

Re: Before Close Event to save changes to Another Workbook

Try this. . .

Code

Option Explicit


Sub Macro1()


    If ThisWorkbook.Name <> "Master.xlsm" Then
        Application.DisplayAlerts = False
        Sheets("Sheet2").Select
        Columns("D:D").Select
        Selection.Copy
        Workbooks.Open ThisWorkbook.Path & "\Master.xlsm"
        With Workbooks("Master.xlsm")
            .Sheets("Sheet2").Select
            .Columns("D:D").Select
            .ActiveSheet.Paste
            .Range("A1").Select
            .Sheets("Sheet1").Select
            .Close savechanges:=True
        End With
        Sheets("Sheet1").Select
        Application.DisplayAlerts = True
    End If
End Sub

Display More

Bill Rockenbach · Aug 11th 2013

Re: Frame a subset of a group of option buttons

You could control the option buttons with the following code

Code

Private Sub OptionButton1_Click()
OptionButton2 = False
OptionButton3 = False
End Sub
Private Sub OptionButton2_Click()
OptionButton1 = False
OptionButton3 = False
End Sub
Private Sub OptionButton3_Click()
OptionButton1 = False
OptionButton2 = False
End Sub

Display More

Bill Rockenbach · Aug 10th 2013

Re: Trying to copy and past multiple workbook to three single sheet

Vitor,

The Ozgrid Excel help forum is a free service. I have learned much over the years from Ozgrid so it’s my pleasure to help others on the forum.

If you need further assistance in the future, start a new thread and then send me a Private Message to take a look.

Regards,
Bill

Bill Rockenbach · Aug 10th 2013

Re: Before Close Event to save changes to Another Workbook

Try

Code

Sub Macro1()
     
    If ThisWorkbook.Name <> "Master.xlsm" Then
        Application.DisplayAlerts = False
        Sheets("Sheet2").Select
        Columns("D:D").Select
        Selection.Copy
        Workbooks.Open ThisWorkbook.Path & "\Master.xlsm"
        Sheets("Sheet2").Select
        Columns("D:D").Select
        ActiveSheet.Paste
        Range("A1").Select
        Sheets("Sheet1").Select
        Workbooks("Master.xlsm").Close savechanges:=True
        Sheets("Sheet1").Select
        Application.DisplayAlerts = True
    End If
End Sub

Display More

Bill Rockenbach · Aug 10th 2013

Re: Trying to copy and past multiple workbook to three single sheet

I had assumed your file open procedure was working OK. Its not.

Try this version

Code

Option Explicit


Sub Openandcopy()


'Macro recorded by Vitor Moreira on 8-aug-2013
    Dim FR As String
    Dim Copyfiles As String
    Dim OK As String
    Dim FileType As String
    Dim Filepath As String
    Dim OutputSheet As String
    Dim Curr_File As Variant
    Dim FldrWkbk As Workbook
    Dim NextRow As Long


    FR = MsgBox("Você criou uma pasta FR no diretório C:\?", vbInformation + vbYesNo, "Criou a pasta?")


    If (FR = vbNo) Then
        Exit Sub
    ElseIf (FR = vbYes) Then


    End If


    Copyfiles = MsgBox("Você copiou os arquivos de resumo para a pasta?", vbInformation + vbYesNo, "Copiou os arquivos?")


    If (Copyfiles = vbNo) Then
        Exit Sub
    ElseIf (Copyfiles = vbYes) Then


    End If


    OK = MsgBox("Clique no botão NO nas telas seguintes", vbInformation + vbOKOnly, "ATENÇÃO")


    FileType = "*.xls*"    'The file type to search for
    Filepath = "C:\FR\"    'The folder to search


    Curr_File = Dir(Filepath & FileType)


    Do Until Curr_File = ""
        Set FldrWkbk = Workbooks.Open(Curr_File)    'Open new data file


        '    Values related to SBS1213 are Side by Side, Demo Plot and Faixa Comercial; to ST1213
        '    are Strip Test and Mini Strip Test; and to MP1213, MPCV
        Select Case FldrWkbk.Sheets("Informações de campo").Range("K4").Value


        Case "Side by Side", "Demo Plot", "Faixa Comercial": OutputSheet = "SBS1213"
        Case "Strip Test", "Mini Strip Test": OutputSheet = "ST1213"
        Case "MPCV": OutputSheet = "MP1213"
        Case Else
            MsgBox "Não foi possível procees workbook  " & FldrWkbk.Name & "  ." & vbLf & _
                   "O valor da célula é incorreto.", vbCritical, "Erro de processamento"
            Exit Sub
        End Select




        Worksheets("Printer").UsedRange.Copy    'Copy data from specific Range


        'Move back to Master file
        Workbooks("FR2013.xlsm").Sheets(OutputSheet).Activate
        NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
        If NextRow < 3 Then NextRow = 3    'The first row of the active sheet to start writing to is 3
        Range("A" & NextRow).Select
        ActiveSheet.Paste


        FldrWkbk.Close SaveChanges:=False    'Close the data file


        Curr_File = Dir    'Select Next File


    Loop


    Set Curr_File = Nothing


End Sub

Display More

Bill Rockenbach · Aug 10th 2013

Re: Trying to copy and past multiple workbook to three single sheet

Hard to test without your files, but I think this will work

Code

Option Explicit
Sub Openandcopy()


'Macro recorded by Vitor Moreira on 8-aug-2013
    Dim FR As String
    Dim Copyfiles As String
    Dim OK As String
    Dim FileType As String
    Dim Filepath As String
    Dim OutputSheet As String
    Dim Curr_File As Variant
    Dim FldrWkbk As Workbook
    Dim NextRow As Long




    FR = MsgBox("Você criou uma pasta FR no diretório C:\?", vbInformation + vbYesNo, "Criou a pasta?")


    If (FR = vbNo) Then
        Exit Sub
    ElseIf (FR = vbYes) Then


    End If


    Copyfiles = MsgBox("Você copiou os arquivos de resumo para a pasta?", vbInformation + vbYesNo, "Copiou os arquivos?")


    If (Copyfiles = vbNo) Then
        Exit Sub
    ElseIf (Copyfiles = vbYes) Then


    End If


    OK = MsgBox("Clique no botão NO nas telas seguintes", vbInformation + vbOKOnly, "ATENÇÃO")


    FileType = "*.xls*"    'The file type to search for
    Filepath = "C:\FR\"    'The folder to search


    Curr_File = Dir(Filepath & FileType)


    Set FldrWkbk = Workbooks.Open(Filepath & Curr_File, False, True)    'Open new data file


    Do Until Curr_File = ""


        '    Values related to SBS1213 are Side by Side, Demo Plot and Faixa Comercial; to ST1213
        '    are Strip Test and Mini Strip Test; and to MP1213, MPCV
        Select Case FldrWkbk.Sheets("Informações de campo").Range("K4").Value


        Case "Side by Side", "Demo Plot", "Faixa Comercial": OutputSheet = "SBS1213"
        Case "Strip Test", "Mini Strip Test": OutputSheet = "ST1213"
        Case "MPCV": OutputSheet = "MP1213"
        Case Else
            MsgBox "Não foi possível procees workbook  " & ThisWorkbook.Name & "  ." & vbLf & _
                   "O valor da célula é incorreto.", vbCritical, "Erro de processamento"
            Exit Sub
        End Select




        Worksheets("Printer").UsedRange.Copy    'Copy data from specific Range


        'Move back to Master file
        Workbooks("FR2013.xlsm").Sheets(OutputSheet).Activate
        NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
        If NextRow < 3 Then NextRow = 3 'The first row of the active sheet to start writing to is 3
        Range("A" & NextRow).Select
        ActiveSheet.Paste


        FldrWkbk.Close SaveChanges:=False    'Close the data file
        Curr_File = Dir    'Select Next File
    Loop


    Set FldrWkbk = Nothing


End Sub

Display More

Bill Rockenbach · Aug 10th 2013

Re: Trying to copy and past multiple workbook to three single sheet

I think you said:

For each workbook opened there are two worksheets. One is named “Informações de campo” and the other is named “Printer”.

Based on a key value in range K4 on worksheet “Informações de campo”, the used range on worksheet “Printer” is to be copied to the next available row in a specific worksheet in a Workbook named “FR2013“.

The worksheets in workbook “FR2013” are named SBS1213, ST1213 and MP1213.

What are the key values and how do the relate to the worksheets SBS1213, ST1213 and MP1213 ?

Bill Rockenbach · Aug 9th 2013

Re: Trying to copy and past multiple workbook to three single sheet

The program looks at each sheet in the active workbook and has three "if" statements to check the name of the sheet. It makes no difference if you have only one "Printer" sheet.
The "Next Without For" message is a programing error. The program will not even run when this error is detected.
I tested the program and do not get this error.
Are you copying the code exactly as I posted it?

Bill Rockenbach · Aug 9th 2013

Re: Trying to copy and past multiple workbook to three single sheet

I moved all your dimension statements to the beginning of your procedure. It makes it easier to read the code.
Always use Option Explicit at the top of your code module. This forces you to dim every variable. This way you will not have a problem of misspelling variable names and variables will not be dimensioned as Variant unless you want them to be a Variant.

I noticed "OutputCol" (which you have commented as a row and dimensioned as a variant) is doing nothing in your code.

Try this revised code . . .

Code

Option Explicit


Sub Openandcopy()


'Macro recorded by Vitor Moreira on 8-aug-2013
    Dim FR As String
    Dim Copyfiles As String
    Dim OK As String
    Dim FileType As String
    Dim Filepath As String
    Dim OutputCol As Long
    Dim Curr_File As Variant
    Dim FldrWkbk As Workbook
    Dim ws As Worksheet
    Dim lMaxRows As Long




    FR = MsgBox("Você criou uma pasta FR no diretório C:\?", vbInformation + vbYesNo, "Criou a pasta?")


    If (FR = vbNo) Then
        Exit Sub
    ElseIf (FR = vbYes) Then


    End If


    Copyfiles = MsgBox("Você copiou os arquivos de resumo para a pasta?", vbInformation + vbYesNo, "Copiou os arquivos?")


    If (Copyfiles = vbNo) Then
        Exit Sub
    ElseIf (Copyfiles = vbYes) Then


    End If


    OK = MsgBox("Clique no botão NO nas telas seguintes", vbInformation + vbOKOnly, "ATENÇÃO")


    FileType = "*.xls*"    'The file type to search for
    Filepath = "C:\FR\"    'The folder to search


    OutputCol = 3    'The first row of the active sheet to start writing to


    Curr_File = Dir(Filepath & FileType)


    Set FldrWkbk = Workbooks.Open(Filepath & Curr_File, False, True)    'Open new data file
    
    Do Until Curr_File = ""
        For Each ws In ThisWorkbook.Worksheets    '*************
        
            If ws.Name = "Printer" Then    '***************
                If FldrWkbk.Sheets("Informações de campo").Range("K4").Value = "Side by Side" Then
                    ws.UsedRange.Copy    'Copy data from specific Range


                    'Move back to Master file
                    Workbooks("FR2013.xlsm").Sheets("SBS1213").Activate
                    ActiveSheet.Range("A2").Select
                    ActiveSheet.Paste
                    lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
                    Range("A" & lMaxRows + 1).Select
                    OutputCol = OutputCol + 1
                End If
            ElseIf ws.Name = "Another Name" Then    '************
                'copy data '*****************
            ElseIf ws.Name = "Some Other Name" Then    '*************
                'copy data  '***********************
            End If    '*************
        Next ws    '*********************


        FldrWkbk.Close SaveChanges:=False    'Close the data file
        Curr_File = Dir    'Select Next File
    Loop


    Set FldrWkbk = Nothing


End Sub

Display More

Bill Rockenbach · Aug 9th 2013

Re: Before Close Event to save changes to Another Workbook

I see a number of problems
1. If several people have access to the master, there is no control to prevent more than one person to attempt to use the master at the same time.

2. I assume the Before_Close Event in the Servant was in the Master. But this code causes the master to open and close. So when the Master closes it causes it’s copy of the Before_Close Event to fire which fires over and over as the Master is repeatedly opened and closed by the Before_Close Event code. Suggest adding an if statement to test if the Servant is running the code

3. In your code there are two places you copy, but then do not past.

Code

Sub macro1()
'


    If ThisWorkbook.Name = "Servant" Then
        Application.DisplayAlerts = False
        Sheets("Sheet2").Select
        Columns("D:D").Select
        Selection.Copy
        Workbooks.Open ThisWorkbook.Path & "\Master.xlsm"
        Sheets("Sheet2").Select
        Columns("D:D").Select
        ActiveSheet.Paste
        Range("A1").Select
        Sheets("Sheet1").Select
        ActiveCell.Copy ‘<<<<<<<<<<<<<<<< no paste
        ThisWorkbook.Close savechanges:=True
        Range("A1").Copy   ‘ <<<<<<<<<<<<< no paste
        Sheets("Sheet1").Select
        Application.DisplayAlerts = True
    End If
End Sub

Display More

Bill Rockenbach · Aug 9th 2013

Re: Change text in cell depending on range

Try this . . .

Code

Sub Test()
    Dim rngDate As Range
    For Each rngDate In Range("AD2:AD40")
        If IsDate(rngDate.Value) And rngDate.Value = Range("D3").Value Then    'date in cell D3 matches rngDate
            Worksheets("Sheet1").Range("B5") = "A"
            Range("B5:C5").Interior.Color = RGB(30, 144, 255)
            Range("B5:C5").Font.Color = RGB(0, 0, 0)
            Exit Sub
        Else
            Worksheets("Sheet1").Range("B5:C5").Clear
        End If
    Next rngDate
End Sub

Display More

Bill Rockenbach · Aug 9th 2013

Re: Trying to copy and past multiple workbook to three single sheet

After opening a workbook you need to loop through the worksheets in the workbook and test for the name of the sheet

I added some suggested code to do this. The added code is identified with a string of asterisks.

Code

Option Explicit


Sub Openandcopy()


'Macro recorded by Vitor Moreira on 8-aug-2013




    Dim FR As String
    FR = MsgBox("Você criou uma pasta FR no diretório C:\?", vbInformation + vbYesNo, "Criou a pasta?")


    If (FR = vbNo) Then
        Exit Sub
    ElseIf (FR = vbYes) Then


    End If




    Dim Copyfiles As String
    Copyfiles = MsgBox("Você copiou os arquivos de resumo para a pasta?", vbInformation + vbYesNo, "Copiou os arquivos?")


    If (Copyfiles = vbNo) Then
        Exit Sub
    ElseIf (Copyfiles = vbYes) Then


    End If




    Dim OK As String
    OK = MsgBox("Clique no botão NO nas telas seguintes", vbInformation + vbOKOnly, "ATENÇÃO")




    FileType = "*.xls*"    'The file type to search for
    FilePath = "C:\FR\"    'The folder to search


    Dim OutputCol As Variant
    Dim Curr_File As Variant
    Dim FldrWkbk As Workbook
    Dim ws As Worksheet    '*************


    OutputCol = 3    'The first row of the active sheet to start writing to


    Curr_File = Dir(FilePath & FileType)


    Set FldrWkbk = Workbooks.Open(FilePath & Curr_File, False, True)    'Open new data file


    Do Until Curr_File = ""
        For Each ws In ActiveWorkbook    '*************
            If ws.Name = "Printer" Then    '***************
                If FldrWkbk.Sheets("Informações de campo").Range("K4").Value = "Side by Side" Then
                    ws.UsedRange.Copy    'Copy data from specific Range


                    'Move back to Master file
                    Workbooks("FR2013.xlsm").Sheets("SBS1213").Activate
                    ActiveSheet.Range("A2").Select
                    ActiveSheet.Paste
                    lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
                    Range("A" & lMaxRows + 1).Select
                    OutputCol = OutputCol + 1
                End If
            ElseIf ws.Name = "Another Name" Then '************
                'copy data '*****************
            ElseIf ws.Name = "Some Other Name" Then '*************
                'copy data  '***********************
            End If    '*************
        Next ws    '*********************




        FldrWkbk.Close SaveChanges:=False    'Close the data file
        Curr_File = Dir    'Select Next File
    Loop
    Set FldrWkbk = Nothing




End Sub

Display More