Link to home
Start Free TrialLog in
Avatar of Naresh Patel
Naresh PatelFlag for India

asked on

Simple Excel VBA

Hi experts,

I have code which match sheets names of two WB from Third WB & perform some task.
I want to add some procedure - if WB Data - sheet x (X is just assumption) not match in WB Results - Sheets then.

this  is already there in code just for understanding.
Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        varData = Split(InputBox("Please enter value for L3:N3, seperated by a space.", "Data input"), " ")

        wbCurrent.Sheets(1).Range("L3").Value = varData(0)
        wbCurrent.Sheets(1).Range("M3").Value = varData(1)
        wbCurrent.Sheets(1).Range("N3").Value = varData(2)

Open in new window


After this - create new sheet in WB Result (name is same as WB Data - Sheet Name)
                   Copy L3:N3 from WB Process & Past To this new sheet - location A3:C3.

this my original whole code.
Sub Demo()

    Dim wbCurrent As Workbook, wbData As Workbook, wbResult As Workbook

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")
    wbData.Activate
    SortWorksheets
    Set wbResult = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")
    wbResult.Activate
    SortWorksheets

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        varData = Split(InputBox("Please enter value for L3:N3, seperated by a space.", "Data input"), " ")

        wbCurrent.Sheets(1).Range("L3").Value = varData(0)
        wbCurrent.Sheets(1).Range("M3").Value = varData(1)
        wbCurrent.Sheets(1).Range("N3").Value = varData(2)
    End If
    
    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()
     
    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean
     
    SortDescending = False
     
    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = 3
        LastWSToSort = Worksheets.Count - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If
     
    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M
     
End Sub

Open in new window



Thanks
Avatar of Joe Howard
Joe Howard
Flag of United States of America image

Sorry for the delay, life got in the way...

This should do it:
Option Explicit


Sub Demo()

    Dim wbCurrent As Workbook, wbData As Workbook, wbResult As Workbook

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")
    wbData.Activate
    SortWorksheets
    Set wbResult = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")
    wbResult.Activate
    SortWorksheets

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        varData = Split(InputBox("Please enter value for L3:N3, seperated by a space.", "Data input"), " ")

        wbCurrent.Sheets(1).Range("L3").Value = varData(0)
        wbCurrent.Sheets(1).Range("M3").Value = varData(1)
        wbCurrent.Sheets(1).Range("N3").Value = varData(2)
        
        wbResult.Activate
        Sheets.Add.Name = wbData.Sheets(1).Name
        
        wbCurrent.Activate
        wbCurrent.ActiveSheet.Range("L3:N3").Copy
        
        wbResult.Activate
        Range("A3:C3").PasteSpecial
    End If
    
    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()
     
    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean
     
    SortDescending = False
     
    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = 3
        LastWSToSort = Worksheets.Count - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If
     
    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M
     
End Sub

Open in new window

Avatar of Naresh Patel

ASKER

life got in the way...

???? "Candy Crush" ;)
Off the Desk for 2 hours. way back to home.

Thanks
That's your mistake, I just copied the code from above!

Add:
Dim varData() As String

Open in new window

Thumbs up for including the error :)
Mr.MacroShadow,
I will check this code tomorrow, here too late & my kid don't allow me to seat in front of computer.

Thanks
Online?
ok I had tested your code thing is that it create new sheet in name of "Ticker" & then Error.User generated imageUser generated image
Thanks
In short I want code perform in Process WB.
it match each sheet from WB Data to each sheet in WB Result.
if found then ..... else ......already mention in the code as you are the creator of this code.
you know very well.

so at the end of this Sub Demo ()

my both WB Data & Result have same number of Sheets with same names. (Between Sheet "Start - Finish"

Note : - Only Match Sheets which is Between Sheets "Start" - Finish" in both WB (Data & Result)

Thanks
After this - create new sheet in WB Result (name is same as WB Data - Sheet Name)

That's what this line does:
Sheets.Add.Name = wbData.Sheets(1).Name

Open in new window

It creates a new sheet in result workbook with the same name as the first sheet in the data workbook.

If that isn't what you want please explain what you do.

And once again please include the error message, how am I to know what the problem is?
One More Thing I Noticed You Posted Your Comment @Yesterday morning thru out  Evening to me @ Night @ Mid night to other Author @ you are still online.

You Are Not Sleeping ??? ;)
Did You Seen My This  Comment?
Couldn't write this if I was sleeping ...
Slow down, You don't give me a chance to respond between your posts. I'm heading out for about 20 minutes, I'll resume when I come back.
Sorry wrong question "You don't Sleep?" :)
okie
You don't Sleep?
Only sometimes ...
Copy L3:N3 from WB Process & Past To this new sheet - location A3:C3.
When is this supposed to happen?
This Situation occur when there is No sheet found in Result WB . so After Input box entry.
I'm still not sure exactly what you want.

1. When do you want to compare and add the missing sheets  to the Result workbook?
2. When do you want to copy L3:N3 from the Process workbook?
3. In which sheet should those values be pasted?
1. When do you want to compare and add the missing sheets  to the Result workbook?
When? I want it compare all sheet from Sheet "Start- Finish" so there is no event when to compare it, is like counter do it for all sheet. if result WB have then IF Code part. else Else Code Part.
2. When do you want to copy L3:N3 from the Process workbook?
It is after I manually enter "Input Box Values Space separated". This will happen in criteria when then is no match found in sheet between Data WB & Result WB.
3. In which sheet should those values be pasted?
New Sheet which created (when No match found).

I know you are beating the bush & wondered what mi achieving by this.
But in next question total picture will clear to you. in which whole actual data is there not like 100 200 300 & A B C.

Thanks
Try this:
Option Explicit

Sub Demo()

    Dim wbCurrent As Workbook, wbData As Workbook, wbResult As Workbook
    Dim ws As Worksheet
    Dim varData() As String
    Dim strSheetName As String
    
    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")
    
    wbData.Activate
    SortWorksheets
    
    Set wbResult = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")
    
    wbResult.Activate
    SortWorksheets

    For Each ws In wbData.Worksheets
        If ws.Index > wbData.Sheets("Start").Index And ws.Index < wbData.Sheets("Finish").Index Then
            If wbResult.Sheets(ws.Index).Name <> ws.Name Then
                wbResult.Sheets.Add.Name = ws.Name
                strSheetName = ws.Name
            End If
        End If
    Next
    
    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        varData = Split(InputBox("Please enter value for L3:N3, seperated by a space.", "Data input"), " ")

        wbCurrent.Sheets(1).Range("L3").Value = varData(0)
        wbCurrent.Sheets(1).Range("M3").Value = varData(1)
        wbCurrent.Sheets(1).Range("N3").Value = varData(2)
        
        wbCurrent.Activate
        wbCurrent.ActiveSheet.Range("L3:N3").Copy
        
        wbResult.Activate
        wbResult.Sheets(strSheetName).Range("A3:C3").PasteSpecial
        
    End If
    
    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()
     
    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean
     
    SortDescending = False
     
    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = 3
        LastWSToSort = Worksheets.Count - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If
     
    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M
     
End Sub

Open in new window

Sorting  - Creating  is working fine. Now in both WB there is 6 sheets with Name matched.

Only sole issue - i have 6 sheet in Data & Result WB Name " A B C D E F"
                             I had deleted Manually from Result WB "A B C"
                             Run The Code all are created but in "Input message box manual entry"
                             Appear for only one time & these values pasted on Result WB Sheet C.  

Ideally it must ask for all three sheet which are created i .e  A B C

Thanks
Try this:
Option Explicit

Sub Demo()

    Dim wbCurrent As Workbook, wbData As Workbook, wbResult As Workbook
    Dim ws As Worksheet
    Dim varData() As String
    Dim arrSheetName() As String
    Dim i As Integer

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")

    wbData.Activate
    SortWorksheets

    Set wbResult = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")

    wbResult.Activate
    SortWorksheets

    For Each ws In wbData.Worksheets
        If ws.Index > wbData.Sheets("Start").Index And ws.Index < wbData.Sheets("Finish").Index Then
            If wbResult.Sheets(ws.Index).Name <> ws.Name Then
                wbResult.Sheets.Add.Name = ws.Name
                i = i + 1
                ReDim Preserve arrSheetName(0 To i)
                arrSheetName(i) = ws.Name
            End If
        End If
    Next

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        varData = Split(InputBox("Please enter value for L3:N3, seperated by a space.", "Data input"), " ")

        wbCurrent.Sheets(1).Range("L3").Value = varData(0)
        wbCurrent.Sheets(1).Range("M3").Value = varData(1)
        wbCurrent.Sheets(1).Range("N3").Value = varData(2)

        wbCurrent.Activate
        wbCurrent.ActiveSheet.Range("L3:N3").Copy

        i = 0
        For i = LBound(arrSheetName) To UBound(arrSheetName)
            wbResult.Activate
            wbResult.Sheets(arrSheetName(i)).Range("A3:C3").PasteSpecial
            i = i + 1
        Next

    End If

    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()
     
    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean
     
    SortDescending = False
     
    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = 3
        LastWSToSort = Worksheets.Count - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If
     
    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M
     
End Sub

Open in new window

what is the error message?
How about this:
Option Explicit

Sub Demo()

    Dim wbCurrent As Workbook, wbData As Workbook, wbResult As Workbook
    Dim ws As Worksheet
    Dim varData() As String
    Dim arrSheetName() As String
    Dim i As Integer, x As Integer

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")

    wbData.Activate
    SortWorksheets

    Set wbResult = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")

    wbResult.Activate
    SortWorksheets

    For Each ws In wbData.Worksheets
        If ws.Index > wbData.Sheets("Start").Index And ws.Index < wbData.Sheets("Finish").Index Then
            If wbResult.Sheets(ws.Index).Name <> ws.Name Then
                wbResult.Sheets.Add.Name = ws.Name
                i = i + 1
                ReDim Preserve arrSheetName(0 To i)
                arrSheetName(i) = ws.Name
            End If
        End If
    Next

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        varData = Split(InputBox("Please enter value for L3:N3, seperated by a space.", "Data input"), " ")

        wbCurrent.Sheets(1).Range("L3").Value = varData(0)
        wbCurrent.Sheets(1).Range("M3").Value = varData(1)
        wbCurrent.Sheets(1).Range("N3").Value = varData(2)

        wbCurrent.Activate
        wbCurrent.ActiveSheet.Range("L3:N3").Copy

        wbResult.Activate
        For x = LBound(arrSheetName) To UBound(arrSheetName)
            wbResult.Sheets(arrSheetName(x)).Range("A3:C3").PasteSpecial
            x = x + 1
        Next

    End If

    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()
     
    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean
     
    SortDescending = False
     
    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = 3
        LastWSToSort = Worksheets.Count - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If
     
    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M
     
End Sub

Open in new window

at time of error what is the value of:
1. x
2. arrSheetName(x)
i guess C - & A B sheet also created with no data
at time of error what is the value of:
1. x
2. arrSheetName(x)

How do i find? i said C bcoz at that time result WB is open & Mouse cursor is in C Sheet.

Thanks
After This Question Next Question Link.. It is same like what have to done but it with actual data.

i am off the desk for 2 hours. Next question link is last question on this series.

Thanks
In the immediate window (ctrl+G to open it) type:

?x

Then hit enter. what is the result?

next type:

?arrSheetName(x)

Then hit enter. what is the result?
Anybody home?
Sorry For Delay ....my son dont allow me to seat in front of computer. pressing keys.... :)User generated image
it is working properly on your machine?
hold on i had done this in old file which is saved in my home machine. now executing  from pendrive.
I'm clocking out for the next 30 hours or so, I'll be back after that.
okie happy week end cheers!!!!
online?
I hope this will solve your issue:
Option Explicit

Sub Demo()

    Dim wbCurrent As Workbook, wbData As Workbook, wbResult As Workbook
    Dim ws As Worksheet
    Dim varData() As String
    Dim arrSheetName() As String
    Dim i As Integer, x As Integer

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")

    wbData.Activate
    SortWorksheets

    Set wbResult = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")

    wbResult.Activate
    SortWorksheets

    For Each ws In wbData.Worksheets
        If ws.Index > wbData.Sheets("Start").Index And ws.Index < wbData.Sheets("Finish").Index Then
            If wbResult.Sheets(ws.Index).Name <> ws.Name Then
                wbResult.Sheets.Add.Name = ws.Name
                i = i + 1
                ReDim Preserve arrSheetName(0 To i)
                arrSheetName(i) = ws.Name
            End If
        End If
    Next

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        varData = Split(InputBox("Please enter value for L3:N3, seperated by a space.", "Data input"), " ")

        wbCurrent.Sheets(1).Range("L3").Value = varData(0)
        wbCurrent.Sheets(1).Range("M3").Value = varData(1)
        wbCurrent.Sheets(1).Range("N3").Value = varData(2)

        wbCurrent.Activate
        wbCurrent.ActiveSheet.Range("L3:N3").Copy

        x = 1
        wbResult.Activate
        For x = LBound(arrSheetName) To UBound(arrSheetName)
            wbResult.Sheets(arrSheetName(x)).Range("A3:C3").PasteSpecial
            x = x + 1
        Next

    End If

    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()
     
    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean

    SortDescending = False
     
    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = Worksheets("Start").Index + 1 
        LastWSToSort = Worksheets("Finish").Index - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If
     
    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M
     
End Sub

Open in new window

What is the error?
Option Explicit

Sub Demo()

    Dim wbCurrent As Workbook, wbData As Workbook, wbResult As Workbook
    Dim ws As Worksheet
    Dim varData() As String
    Dim arrSheetName() As String
    Dim i As Integer, x As Integer

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")

    wbData.Activate
    SortWorksheets

    Set wbResult = Workbooks.Open("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")

    wbResult.Activate
    SortWorksheets

    For Each ws In wbData.Worksheets
        If ws.Index > wbData.Sheets("Start").Index And ws.Index < wbData.Sheets("Finish").Index Then
            If wbResult.Sheets(ws.Index).Name <> ws.Name Then
                wbResult.Sheets.Add.Name = ws.Name
                i = i + 1
                ReDim Preserve arrSheetName(0 To i)
                arrSheetName(i) = ws.Name
            End If
        End If
    Next

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        varData = Split(InputBox("Please enter value for L3:N3, seperated by a space.", "Data input"), " ")

        wbCurrent.Sheets(1).Range("L3").Value = varData(0)
        wbCurrent.Sheets(1).Range("M3").Value = varData(1)
        wbCurrent.Sheets(1).Range("N3").Value = varData(2)

        wbCurrent.Activate
        wbCurrent.ActiveSheet.Range("L3:N3").Copy

        wbResult.Activate
        For x = LBound(arrSheetName) To UBound(arrSheetName)
            wbResult.Sheets(arrSheetName(x) + 1).Range("A3:C3").PasteSpecial
            x = x + 1
        Next

    End If

    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()
     
    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean

    SortDescending = False
     
    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = Worksheets("Start").Index + 1
        LastWSToSort = Worksheets("Finish").Index - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If
     
    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M
     
End Sub

Open in new window

please send me the relevant files so I can test it.
Finally working (on my machine):

Option Explicit

Sub Demo()

    Dim wbCurrent As Workbook, wbData As Workbook, wbResult As Workbook
    Dim ws As Worksheet
    Dim varData() As String
    Dim arrSheetName() As String
    Dim i As Integer

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open(ActiveWorkbook.Path & "\Data.xlsx")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")

    wbData.Activate
    SortWorksheets

    Set wbResult = Workbooks.Open(ActiveWorkbook.Path & "\Result.xlsx")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")

    wbResult.Activate
    SortWorksheets

    For Each ws In wbData.Worksheets
        If ws.Index > wbData.Sheets("Start").Index And ws.Index < wbData.Sheets("Finish").Index Then
            If (wbResult.Sheets(ws.Index).Name <> ws.Name) Or (ws.Index > Sheets(Sheets.Count).Index - 1) Then
                wbResult.Sheets.Add.Name = ws.Name
                i = i + 1
                ReDim Preserve arrSheetName(0 To i)
                arrSheetName(i) = ws.Name
            End If
        End If
    Next

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        varData = Split(InputBox("Please enter value for L3:N3, seperated by a space.", "Data input"), " ")

        wbCurrent.Sheets(1).Range("L3").Value = varData(0)
        wbCurrent.Sheets(1).Range("M3").Value = varData(1)
        wbCurrent.Sheets(1).Range("N3").Value = varData(2)

        wbCurrent.Activate
        wbCurrent.ActiveSheet.Range("L3:N3").Copy

        i = 0
        wbResult.Activate
        For i = LBound(arrSheetName) To UBound(arrSheetName) - 1
            If i + 1 > wbResult.Sheets("Finish").Index - 1 Then Exit For
            wbResult.Sheets(arrSheetName(i + 1)).Range("A3:C3").PasteSpecial
        Next

    End If

    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()
     
    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean

    SortDescending = False
     
    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = Worksheets("Start").Index + 1
        LastWSToSort = Worksheets("Finish").Index - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If
     
    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M
     
End Sub

Open in new window

Let see what happen on my machine.Going for Prayer.

Revert you back soon.

Thanks
Long prayers ;)
Are You sure Working On Your Machine? i got this ErrorUser generated image
I'm sorry, pasted the wrong code. This is what it should have been:

Option Explicit

Sub Demo()

    Dim wbCurrent As Workbook, wbData As Workbook, wbResult As Workbook
    Dim ws As Worksheet, w As Worksheet
    Dim varData() As String
    Dim arrSheetName() As String
    Dim i As Integer
    Dim blnExists As Boolean

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open(ActiveWorkbook.Path & "\Data.xlsx")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")

    wbData.Activate
    SortWorksheets

    Set wbResult = Workbooks.Open(ActiveWorkbook.Path & "\Result.xlsx")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")

    wbResult.Activate
    SortWorksheets

    For Each ws In wbData.Worksheets
        If ws.Index > wbData.Sheets("Start").Index And ws.Index < wbData.Sheets("Finish").Index Then
            If (wbResult.Sheets(ws.Index).Name <> ws.Name) Or (ws.Index > Sheets(Sheets.Count).Index - 1) Then
                For Each w In wbResult.Worksheets
                    If w.Name = ws.Name Then blnExists = True
                Next
                If Not blnExists Then
                    wbResult.Sheets.Add.Name = ws.Name
                    i = i + 1
                    ReDim Preserve arrSheetName(0 To i)
                    arrSheetName(i) = ws.Name
                End If
            End If
        End If
    Next

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        varData = Split(InputBox("Please enter value for L3:N3, seperated by a space.", "Data input"), " ")

        wbCurrent.Sheets(1).Range("L3").Value = varData(0)
        wbCurrent.Sheets(1).Range("M3").Value = varData(1)
        wbCurrent.Sheets(1).Range("N3").Value = varData(2)

        wbCurrent.Activate
        wbCurrent.ActiveSheet.Range("L3:N3").Copy

        i = 0
        wbResult.Activate
        For i = LBound(arrSheetName) To UBound(arrSheetName) - 1
            If i + 1 > wbResult.Sheets("Finish").Index - 1 Then Exit For
            wbResult.Sheets(arrSheetName(i + 1)).Range("A3:C3").PasteSpecial
        Next

    End If

    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()
     
    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean

    SortDescending = False
     
    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = Worksheets("Start").Index + 1
        LastWSToSort = Worksheets("Finish").Index - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If
     
    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M
     
End Sub

Open in new window

Yes Working fine from previous errors now no errors but i guess you miss one Point. Input message box ask for manually entry for each sheet which is not in Result.

Thanks
Do u want me to close this question and play with real data?
You want to be prompted for each sheet?
Yes
How about this:
Option Explicit

Sub Demo()

    Dim wbCurrent As Workbook, wbData As Workbook, wbResult As Workbook
    Dim ws As Worksheet, w As Worksheet
    Dim varData() As String
    Dim arrSheetName() As String
    Dim i As Integer
    Dim blnExists As Boolean

    Set wbCurrent = ActiveWorkbook
    Set wbData = Workbooks.Open(ActiveWorkbook.Path & "\Data.xlsx")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Data.xlsx")

    wbData.Activate
    SortWorksheets

    Set wbResult = Workbooks.Open(ActiveWorkbook.Path & "\Result.xlsx")    '("H:\4.Trading Master\Thunderbolt\Simple Excel Formula\Result.xlsx")

    wbResult.Activate
    SortWorksheets

    For Each ws In wbData.Worksheets
        If ws.Index > wbData.Sheets("Start").Index And ws.Index < wbData.Sheets("Finish").Index Then
            If (wbResult.Sheets(ws.Index).Name <> ws.Name) Or (ws.Index > Sheets(Sheets.Count).Index - 1) Then
                For Each w In wbResult.Worksheets
                    If w.Name = ws.Name Then blnExists = True
                Next
                If Not blnExists Then
                    wbResult.Sheets.Add.Name = ws.Name
                    i = i + 1
                    ReDim Preserve arrSheetName(0 To i)
                    arrSheetName(i) = ws.Name
                End If
            End If
        End If
    Next

    wbData.Activate

    If wbData.Sheets(1).Name = wbResult.Sheets(1).Name Then
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        wbResult.Activate
        wbResult.Sheets(1).Range("A3:C3").Copy
        wbCurrent.Activate
        Range("L3:N3").PasteSpecial
    Else
        wbData.Sheets(1).Range("A1:F" & Range("F1048576").End(xlUp).Row).Copy
        wbCurrent.Activate
        Range("A1").PasteSpecial

        i = 0
        wbResult.Activate
        For i = LBound(arrSheetName) To UBound(arrSheetName) - 1
            If i + 1 > wbResult.Sheets("Finish").Index - 1 Then Exit For
            varData = Split(InputBox("Please enter value for L3:N3 in sheet " & wbResult.Sheets(arrSheetName(i + 1)).Name & ", seperated by a space.", "Data input"), " ")
            wbResult.Sheets(arrSheetName(i + 1)).Range("L3").Value = varData(0)
            wbResult.Sheets(arrSheetName(i + 1)).Range("M3").Value = varData(1)
            wbResult.Sheets(arrSheetName(i + 1)).Range("N3").Value = varData(2)
        Next

    End If

    wbData.Activate
    SortWorksheets
    wbResult.Activate
    SortWorksheets

    wbData.Close True
    wbResult.Close True

End Sub

Private Sub SortWorksheets()
     
    Dim N As Integer
    Dim M As Integer
    Dim FirstWSToSort As Integer
    Dim LastWSToSort As Integer
    Dim SortDescending As Boolean

    SortDescending = False
     
    If ActiveWindow.SelectedSheets.Count = 1 Then
        FirstWSToSort = Worksheets("Start").Index + 1
        LastWSToSort = Worksheets("Finish").Index - 1
    Else
        With ActiveWindow.SelectedSheets
            For N = 2 To .Count
                If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                    MsgBox "You cannot sort non-adjacent sheets"
                    Exit Sub
                End If
            Next N
            FirstWSToSort = .Item(1).Index
            LastWSToSort = .Item(.Count).Index
        End With
    End If
     
    For M = FirstWSToSort To LastWSToSort
        For N = M To LastWSToSort
            If SortDescending = True Then
                If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            Else
                If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                    Worksheets(N).Move Before:=Worksheets(M)
                End If
            End If
        Next N
    Next M
     
End Sub

Open in new window

ASKER CERTIFIED SOLUTION
Avatar of Joe Howard
Joe Howard
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Thanks.
May I Ask New Question ...it will take 20 min...?
Go ahead!
May I Post New Question Now?
Go ahead! I've been waiting for the past 3 hours!
ooooppppssss Sorrry apology.....New Question.

Thanks
did you got ? for what mi up too....just put any comment on new question as you know whole history ......if any other will attend -----I have too tell him whole story.

Thanks