Solved

Simple Excel VBA

Posted on 2014-04-03
72
180 Views
Last Modified: 2014-04-07
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
0
Comment
Question by:itjockey
  • 41
  • 31
72 Comments
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39974910
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

0
 
LVL 8

Author Comment

by:itjockey
ID: 39974921
life got in the way...

???? "Candy Crush" ;)
0
 
LVL 8

Author Comment

by:itjockey
ID: 39975008
Error
0
 
LVL 8

Author Comment

by:itjockey
ID: 39975052
Off the Desk for 2 hours. way back to home.

Thanks
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39975171
That's your mistake, I just copied the code from above!

Add:
Dim varData() As String

Open in new window

0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39975175
Thumbs up for including the error :)
0
 
LVL 8

Author Comment

by:itjockey
ID: 39975931
Mr.MacroShadow,
I will check this code tomorrow, here too late & my kid don't allow me to seat in front of computer.

Thanks
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977211
Online?
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977215
Yep.
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977218
ok I had tested your code thing is that it create new sheet in name of "Ticker" & then Error.Ticker Sheet CreatedError
Thanks
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977234
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
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977245
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?
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977248
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 ??? ;)
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977250
Did You Seen My This  Comment?
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977251
Couldn't write this if I was sleeping ...
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977254
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.
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977256
Sorry wrong question "You don't Sleep?" :)
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977260
okie
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977280
You don't Sleep?
Only sometimes ...
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977287
Copy L3:N3 from WB Process & Past To this new sheet - location A3:C3.
When is this supposed to happen?
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977296
This Situation occur when there is No sheet found in Result WB . so After Input box entry.
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977379
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?
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977410
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
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977481
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

0
 
LVL 8

Author Comment

by:itjockey
ID: 39977520
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
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977578
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

0
 
LVL 8

Author Comment

by:itjockey
ID: 39977584
Error
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977590
what is the error message?
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977601
Press Play Button - Input box AppearInserting valuesError Appear After pressing debug
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977682
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

0
 
LVL 8

Author Comment

by:itjockey
ID: 39977685
error
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977689
at time of error what is the value of:
1. x
2. arrSheetName(x)
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977701
i guess C - & A B sheet also created with no data
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977703
???
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977715
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
0
 
LVL 8

Author Comment

by:itjockey
ID: 39977766
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
0
Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

 
LVL 26

Expert Comment

by:MacroShadow
ID: 39977792
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?
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39978154
Anybody home?
0
 
LVL 8

Author Comment

by:itjockey
ID: 39978297
Sorry For Delay ....my son dont allow me to seat in front of computer. pressing keys.... :)Error
0
 
LVL 8

Author Comment

by:itjockey
ID: 39978303
it is working properly on your machine?
0
 
LVL 8

Author Comment

by:itjockey
ID: 39978310
hold on i had done this in old file which is saved in my home machine. now executing  from pendrive.
0
 
LVL 8

Author Comment

by:itjockey
ID: 39978322
Revised Error
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39978398
I'm clocking out for the next 30 hours or so, I'll be back after that.
0
 
LVL 8

Author Comment

by:itjockey
ID: 39978401
okie happy week end cheers!!!!
0
 
LVL 8

Author Comment

by:itjockey
ID: 39980007
online?
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39980307
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

0
 
LVL 8

Author Comment

by:itjockey
ID: 39980869
ERROR
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39980955
What is the error?
0
 
LVL 8

Author Comment

by:itjockey
ID: 39980980
error
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39980984
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

0
 
LVL 8

Author Comment

by:itjockey
ID: 39981079
Error
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39981083
please send me the relevant files so I can test it.
0
 
LVL 8

Author Comment

by:itjockey
ID: 39981129
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39981205
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

0
 
LVL 8

Author Comment

by:itjockey
ID: 39981223
Let see what happen on my machine.Going for Prayer.

Revert you back soon.

Thanks
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39981430
Long prayers ;)
0
 
LVL 8

Author Comment

by:itjockey
ID: 39981570
Are You sure Working On Your Machine? i got this ErrorError
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39981579
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

0
 
LVL 8

Author Comment

by:itjockey
ID: 39981601
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
0
 
LVL 8

Author Comment

by:itjockey
ID: 39981606
Do u want me to close this question and play with real data?
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39981621
You want to be prompted for each sheet?
0
 
LVL 8

Author Comment

by:itjockey
ID: 39981651
Yes
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39981661
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

0
 
LVL 8

Author Comment

by:itjockey
ID: 39982216
Error
0
 
LVL 26

Accepted Solution

by:
MacroShadow earned 500 total points
ID: 39982231
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

        If IsArrayAllocated(arrSheetName) Then
            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

    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

Function IsArrayAllocated(Arr As Variant) As Boolean
    On Error Resume Next
    IsArrayAllocated = IsArray(Arr) And _
                       Not IsError(LBound(Arr, 1)) And _
                       LBound(Arr, 1) <= UBound(Arr, 1)
End Function

Open in new window

0
 
LVL 8

Author Closing Comment

by:itjockey
ID: 39982233
Thanks.
0
 
LVL 8

Author Comment

by:itjockey
ID: 39982237
May I Ask New Question ...it will take 20 min...?
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39982239
Go ahead!
0
 
LVL 8

Author Comment

by:itjockey
ID: 39982521
May I Post New Question Now?
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39982644
Go ahead! I've been waiting for the past 3 hours!
0
 
LVL 8

Author Comment

by:itjockey
ID: 39982653
ooooppppssss Sorrry apology.....New Question.

Thanks
0
 
LVL 8

Author Comment

by:itjockey
ID: 39982798
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
0

Featured Post

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

PaperPort has a feature called the "Send To Bar". It provides a convenient, drag-and-drop interface for using other installed software, such as Microsoft Office. However, this article shows that the latest Office 2016 apps (installed with an Office …
Entering a date in Microsoft Access can be tricky. A typo can cause month and day to be shuffled, entering the day only causes an error, as does entering, say, day 31 in June. This article shows how an inputmask supported by code can help the user a…
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now