Posts by Ger Plante

The code fails on:

Range("C" & R).Value = Me.TextBox1.Value

So you are trying to put the value of the textbox into Colum "C" at Row "R". The value of R is actually blank or empty and needs to be set.

R is set with the following code.

R = Range("A1").Value

Which basically means, take the value from Cell A1 on the active sheet and set R to that value.

Cell A1 is currently blank. If you put a number in Cell A1 that represents a row number then the code will work.

I suspect there was a formula in "A1" in the workbook or sheet that you copied this from, and that formula would return the last row in the table

I suspect the formula was something like:
=COUNTA(B2:B164)+1

You may not be able to see the formula because the font is set to white on a white background.

Ger

Code looks pretty OK as far as I can tell... I would suggest letting the error happen with an on error resume next...

That aside - how many rows & columns are typically in the list object? Filtering a list object shouldnt take that long, unless there was a lot of rows...

Yes - if the message box is displaying the filename only then it should be fine. That means that VBA can "reach" the file.

It could be an issue with the shared drive. Is there a chance that someone is editing /creating / locking the file that you are trying to attach?

The only other thing to try and ensure the path is OK... is instead of
msgbox DIR(strAttachment)
use
debug.print strAttachment

Then press Control key+G to go to the interactive debug window and copy/paste the value that is displayed there into the clipboard. Now go to the windows Run screen (or Windows Key+R), paste the string into the run window and press enter. That should immediately load the file. If it doesnt it could be something wrong with the path to the file, or the file itself could be locked... Regards Ger

No need to resurrect old threads by the way
And cool user name

Well, depends on the version of Excel...
https://support.office.com/en-…43-467e-8e27-269d656771c3

2013/2016:

Plenty of examples here and on the web to combine multiple worksheets into a master workbook.

e.g. http://www.vbaexpress.com/kb/getarticle.php?kb_id=773

Ger

Make sure all object or range references have been set = nothing before you ".quit".
Make sure .displayalerts and .screenupdating and .calculation are switched back "on/automatic" before .quit.
Make sure there is no other application trying to reference Excel...

Almost impossible to say without having your actual file... couple of pointers though:

1. .activate and .select This is bad practice - you should not need to ever activate a sheet or select a range. Never do this. It is SLOW... So lets focus on this...

Set Result = DEsheet.Columns(3).Find(What:=FindLabel, LookAt:=xlWhole) 'find the caption of the label on DEsheet column
If Not Result Is Nothing Then 'If It is found
DEsheet.Activate
Result.Select ' i believe this line is where it really slows down, im having trouble finding a different way to grab the value it finds though
UserForm2.Controls("ComboBox" & a).value = ActiveCell.Offset(0, 1).value 'number of notes from column 4 goes in Note ComboBox for that label
UserForm2.Controls("CheckBox" & a).value = True 'checkbox for that label gets checked

Since Result is a range, you can just refer to that range... no need to select it or activate. Try this instead.

Set result = DEsheet.Columns(3).Find(What:=FindLabel, LookAt:=xlWhole) 'find the caption of the label on DEsheet column 3
If Not result Is Nothing Then 'If It is found    
UserForm2.Controls("ComboBox" & a).Value = result.Offset(0, 1).Value 'number of notes from column 4 goes in Note ComboBox for that label    
UserForm2.Controls("CheckBox" & a).Value = True 'checkbox for that label gets checked End Sub

2. Setting application.enablevents = false does NOT effect the events on userform controls... it only prevents events from triggering on the WORKSHEET. This leads me to point 3.

3. You are setting the values of checkboxes on a userform - is there CODE on the change event for those controls? If so, then changing their values through VBA code will trigger the "change event" for those controls. (e.g. UserForm2.Controls("CheckBox" & a).Value = True will trigger the change event for that control.

4. If your list box is linked via .rowsource property to a range in the workbook, then changing the workbook values to something else will probably trigger the listbox change event too (I'm only about 60% certain of this...)

HTH
Ger

Hi JL - sorry, you have totally confused me. It doesnt help that I cant see your actual data. So i'm flying blind. I dont know which code works closest to the best for you right now. I dont know if you want or dont want to see the actual formulas in the summary table, or the result of the formula s in the summary table. Too many unknowns for me able to to fix the code you have.

I am going to assume that at least one of the code samples seems to work (not sure which one). and that the new "problem" is blank rows in the middle of the summary table. The following Code will delete blank rows from that table.

So it doesnt matter which code you are currently using, just use this code at the end to remove blank rows. You can call it manually, or you can insert into the existing macro you have (which ever one you are using.). Just put the words "Clean_table" at the end of which ever macro you are using.

Public Sub clean_table()


Dim ws As Worksheet
Dim r As Range


Set ws = Worksheets("Summary")
Set r = ws.Range("B4").CurrentRegion
r.AutoFilter
r.AutoFilter 1, "" 'filter for column 1 for blank rows
On Error Resume Next
r.Offset(1, 0).Resize(r.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
On Error GoTo 0
r.AutoFilter


End Sub

If you continue to have problems, maybe start a new thread about the existing issue, and show some representative data, with confidential data removed from the file It will make fixing this a lot easier.

Ger

So If I understand what you are saying - you are ending up with Blank rows of data in the summary table? If so, I would actually just let the code run as it is right now, and just run a small macro at the end to remove blank rows from summary the table.

MODERATOR NOTICE: This topic has also been posted on other sites and may already have an answer elsewhere. Please take this into consideration when answering this question

*

This works I think....

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)


If ActiveCell.Column = 1 Then
'David McRitchie, 2007-09-07 insrtrow.htm on double-click
'-- will copy more often than Extend Formulas and Format (tools option)
Cancel = True
Cells(Target.Row, 1).EntireRow.Insert
Target.EntireRow.Copy Destination:=Cells(Target.Row - 1, 1)
Intersect(Cells(Target.Row - 1, 1).EntireRow, Range("E:IV")).SpecialCells(xlConstants).ClearContents
Cells(Target.Row - 1, 5).Resize(2).Value = 1
On Error GoTo 0
Else
End If
End Sub

Well... youre taking a sledge hammer to crack a nut to be honest... but here is the code that works on your sample file. Just some of the cell references were off a small but.

Option Explicit
Public Sub CombineDataFromAllSheets()


    Dim wksSrc As Worksheet, wksDst As Worksheet
    Dim rngSrc As Range, rngDst As Range
    Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
    
    'Notes: "Src" is short for "Source", "Dst" is short for "Destination"
    
    'Set references up-front
    Set wksDst = ThisWorkbook.Worksheets("Summary")
    lngDstLastRow = LastOccupiedRowNum(wksDst)
    lngLastCol = LastOccupiedColNum(wksDst)
    
    'Set the initial destination range
    Set rngDst = wksDst.Cells(lngDstLastRow + 1, 2)
    
    'Loop through all sheets
    For Each wksSrc In ThisWorkbook.Worksheets
    
        'Make sure we skip the "Import" destination sheet!
        If wksSrc.Name <> "Summary" Then
            
            'Identify the last occupied row on this sheet
            lngSrcLastRow = LastOccupiedRowNum(wksSrc)
            
            'Store the source data then copy it to the destination range
            With wksSrc
                Set rngSrc = .Range(.Cells(5, 2), .Cells(lngSrcLastRow, lngLastCol))
                rngSrc.Copy Destination:=rngDst
            End With
            
            'Redefine the destination range now that new data has been added
            lngDstLastRow = LastOccupiedRowNum(wksDst)
            Set rngDst = wksDst.Cells(lngDstLastRow + 1, 2)
            
        End If
    
    Next wksSrc


End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last row
'OUTPUT      : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    LastOccupiedRowNum = lng
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last column
'OUTPUT      : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByColumns, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Column
        End With
    Else
        lng = 1
    End If
    LastOccupiedColNum = lng
End Function

But to be honest if all you are struggling with is the sheet names not being named FNC, then I would go with my shorter code... its easier to maintain. i.e. I'm not sure why you would use 30 lines of code instead of my 10 lines. I have updated it to ignore sheet names. You now have two working solutions for the sample file in post #1

Public Sub Summarize()


Dim r As Range
Dim ws As Worksheet


'On Error Resume Next
Worksheets("Summary").Range("b4").CurrentRegion.Offset(1).ClearContents


For Each ws In ThisWorkbook.Worksheets
        If LCase(ws.Name) <> "summary" Then
            Set r = ws.Range("B5:G" & ws.Range("B" & Rows.Count).End(xlUp).Row) 'set range to copy
            r.Copy Worksheets("Summary").Range("B" & Rows.Count).End(xlUp).Offset(1) 'copy the range
        End If
Next
End Sub

You were Close - just use the width and height properties of the shape, for example:

'Position and size image
With ActiveSheet.Shapes(1)
.Left = ActiveSheet.Cells(2, 2).Left
.Top = ActiveSheet.Cells(2, 2).Top
.Width = ActiveSheet.Cells(2, 2).Width
.Height = ActiveSheet.Cells(2, 2).Height
end with

Ger

Google "Consolidate workbooks into one" ... for example:
https://trumpexcel.com/combine-multi...cel-workbooks/

and

http://www.rondebruin.nl/win/addins/rdbmerge.htm

Hmmm. honestly, not sure... that error looks unrelated to the one line of code that I added in (you could verify, by just commenting out the line that i added in

'Cells(Target.Row, 5).resize(2).Value = 1

In any case, my best guess here is that the activesheet part is causing a problem... so instead try this adapted version of the code which doesnt ".select" anything, or reference the activesheet. (In general in VBA Code there is no need ever to .Select anything anything, and very few situations where you need to refer to the activesheet).

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)


 If ActiveCell.Column = 1 Then
  'David McRitchie,  2007-09-07    insrtrow.htm on double-click
  '-- will copy more often than  Extend Formulas and Format (tools option)
  Cancel = True
  Cells(Target.Row + 1, 1).EntireRow.Insert
  Target.EntireRow.Copy Destination:=Cells(Target.Row + 1, 1)
  Intersect(Cells(Target.Row + 1, 1).EntireRow, Range("E:IV")).SpecialCells(xlConstants).ClearContents
  Cells(Target.Row, 5).Resize(2).Value = 1
  On Error GoTo 0
 Else
End If
End Sub

Final comment - setting calculation to manual is like taking the oil light out of the car dashboard to prevent it from coming on. Its rarely a good idea Might be time to rethink your formula/vba approach.

Ger

Is this happening EVERY time you run the macro, or just occasionally? I would guess that the path to the file or the file name itself is incorrect, or contains some invalid characters...

Right before

.Attachments.Add =strAttachment

Use:

msgbox DIR(strAttachment)
.Attachments.Add = strAttachment

That msgbox will display the full path and file name IF and ONLY IF the file name can be found/reached. Otherwise if there is something wrong with path or filename it will just return an empty string/message box

Also, for example, the filename or folder name that you construct as part of the string strAttachments can not contain "*" or "/" or "."

See here, for a full list of invalid fileame characters.
https://support.microsoft.com/en-ie/...site-names-fol

Ger

No worries - you should put in a standard module and run it like a standard macro.

This should get you most of the way....

Option Explicit


Public Sub Summarize()


Dim r As Range
Dim ws As Worksheet


'On Error Resume Next
Worksheets("Summary").Range("b4").CurrentRegion.Offset(1).ClearContents


For Each ws In ThisWorkbook.Worksheets


        If Left(LCase(ws.Name), 3) = "fnc" Then
            Set r = ws.Range("B5:G" & ws.Range("B" & Rows.Count).End(xlUp).Row) 'set range to copy
            r.Copy Worksheets("Summary").Range("B" & Rows.Count).End(xlUp).Offset(1) 'copy the range
        End If


Next


End Sub


End If
Next


End Sub

Regards
Ger