COUNT & Copy to Last Row, Paste to another sheet to Last Row (FIRST EMPTY ROW, adding, not replacing

semiro1815 

That won't work - code execution will be paused as long as a MsgBox is displayed.

I'd use the status bar for this purpose - see my previous reply.

Or a modeless userform - see Beautiful VBA Progress Bar with Step by Step Instructions 

semiro1815 

That would be difficult, since you don't know in advance how many workbooks and how many worksheets have to be processed.

You could, however, display which sheet is being processed in the status bar:

Sub CopySheets()
    Dim strDesktop As String
    Dim strFile As String
    Dim wbkSource As Workbook
    Dim wshSource As Worksheet
    Dim wbkTarget As Workbook
    
    On Error GoTo ErrHandler
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set wbkTarget = ActiveWorkbook
    strDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    strFile = Dir(strDesktop & "*.xls*")
    Do While strFile <> ""
        Set wbkSource = Workbooks.Open(strDesktop & strFile)
        For Each wshSource In wbkSource.Worksheets
            Application.StatusBar = "Processing '" & wshSource.Name & _
                "' in '" & wbkSource.Name & "'"
            wshSource.Copy After:=wbkTarget.Worksheets(wbkTarget.Worksheets.Count)
        Next wshSource
        wbkSource.Close SaveChanges:=False
        strFile = Dir
    Loop
    
ExitHandler:
    Application.StatusBar = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Sub
    
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

semiro1815 My apologies, I forgot one line

Sub CopySheets()
    Dim strDesktop As String
    Dim strFile As String
    Dim wbkSource As Workbook
    Dim wshSource As Worksheet
    Dim wbkTarget As Workbook
    
    On Error GoTo ErrHandler
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set wbkTarget = ActiveWorkbook
    strDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    strFile = Dir(strDesktop & "*.xls*")
    Do While strFile <> ""
        Set wbkSource = Workbooks.Open(strDesktop & strFile)
        For Each wshSource In wbkSource.Worksheets
            wshSource.Copy After:=wbkTarget.Worksheets(wbkTarget.Worksheets.Count)
        Next wshSource
        wbkSource.Close SaveChanges:=False
        strFile = Dir
    Loop
        
ExitHandler:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Sub
    
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

HansVogelaar 

Emm. i changed the location. but it faces a little issue. i can not get rid of this error message. once it shows blank, once it shows this message. i click "ok" and it pops up over and over again everytime i click ok! 

Yes. Should i change the location of my active workbook? or is there any way to skip this and make it work even if i keep my active workbook in dekstop?

semiro1815 

Has the active workbook been saved on the desktop too?

HansVogelaar 

Hmm actually it copies my current sheet in my active workbook and pastes again (like (2)) and then closes my workbook. It doesnt copy the worksheets of other workbooks from desktop and paste in my workbook! Could you check it once again please?

semiro1815 

Try this:

Sub CopySheets()
    Dim strDesktop As String
    Dim strFile As String
    Dim wbkSource As Workbook
    Dim wshSource As Worksheet
    Dim wbkTarget As Workbook
    
    On Error GoTo ErrHandler
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set wbkTarget = ActiveWorkbook
    strDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    strFile = Dir(strDesktop & "*.xls*")
    Do While strFile <> ""
        Set wbkSource = Workbooks.Open(strDesktop & strFile)
        For Each wshSource In wbkSource.Worksheets
            wshSource.Copy After:=wbkTarget.Worksheets(wbkTarget.Worksheets.Count)
        Next wshSource
        wbkSource.Close SaveChanges:=False
        strFile = Dir
    Loop
        
ExitHandler:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

HansVogelaar 

Hello friend,

I was thinking about a simplicity move. I don't know if it can be done.

So, suppose we are having 2-3 workbooks (or more) in Desktop. I want a VBA code, that when i run it, it copies all the worksheets of every workbook from the desktop-folder and list/paste to my active workbook.

Can this simplicity move be done?

HansVogelaar 

ah this way. that helped. Thank you !

semiro1815 

It would look like this:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    If Not Intersect(Range("B3"), Target) Is Nothing Then
        If Range("B3").Value <> "" Then
            Set rng = Worksheets("Sheet2").Range("A:A").Find _
                (What:=Range("B3").Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not rng Is Nothing Then
                Application.Goto rng, True
            End If
        End If
    End If
    If Not Intersect(Range("S24"), Target) Is Nothing Then
        If Range("S24").Value <> "" Then
            Set rng = Worksheets("Sheet3").Range("A:A").Find _
                (What:=Range("S24").Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not rng Is Nothing Then
                Application.Goto rng, True
            End If
        End If
    End If
End Sub

I simply copied the If ... End If block, and changed B3 to S24 and Sheet2 to Sheet3.

HansVogelaar 

Hmm i tried to put it on one procedure, but it didnt seem to work. could you give it a try? just adding for Sheet3, in column A:A while the search cell is from S24 from the current sheet. Please

semiro1815 

As you have found, you can have only one Worksheet_Change event procedure in a worksheet module,

You'll have to add a second If ... End If block in the existing procedure.

HansVogelaar Yep, works perfect my friend.

And if i want to have two cells for example from the same sheet1? I tried adding another private sub code, down below, but the second cell seemed not to work! Only one worked. 

Or should they be included to one code. for example, i want to add another cell C3 for Sheet3

semiro1815 

Right-click the sheet tab of Sheet1.

Select 'View Code' from the context menu.

Copy the following code into the worksheet module:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    If Not Intersect(Range("B3"), Target) Is Nothing Then
        If Range("B3").Value <> "" Then
            Set rng = Worksheets("Sheet2").Range("A:A").Find _
                (What:=Range("B3").Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not rng Is Nothing Then
                Application.Goto rng, True
            End If
        End If
    End If
End Sub

This code will only find what you enter in B3 if it is the whole cell value (for example, if you enter Excel, it will find a cell that contains Excel, but not a cell that contains Microsoft Excel).

If you want to find the latter too, change xlWhole to xlPart in the code.

HansVogelaar 

Hey friend,

i would like a simple trick, like:

In Sheet1 i want to use cell B3, as a search cell. So when i enter certain text, i want a macro (by pressing a button) that goes to Sheet2 in ColumnA and search for that text and select that cell ! if can't find anything, MsgBox "No resulsts found!".

Can be done?

VERY APPRECIATED! Thank you!