Loop help required to run another macro

earthworm

earthworm

Well-known Member
Joined
May 19, 2009
Messages
773
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
I have numeric values in another sheet by the name of summary.

If cell value in summary sheet example F5 is > 0 or less then 0 or <> 0 only then i want to run the macro for that

particular company .

The problem is if i use if condition it stop running the second macro if the first value is found as true.

My requirement .

if the value in F5 is 0 then move to next and if value in cell F4 > 0 then run second macro and so on . Please help!

Without above loop the macro will create and save all the sheet on desktop in folder Test even if there is no value in cell which is taking a lot of time . There are total 36 companies on which i want to run.

I have posted only few for my understanding and learning.

Code: 
Sub SplitData()
 
' Adler Jung
 
   Range("B6").Select
    Sheets("Dump Data Here").Select
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$W$23916").AutoFilter Field:=4, Criteria1:= _
        "Adler Jung"
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Range("A1:W683").Select
    Selection.Columns.AutoFit
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A2").Select
    Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=50000, Trend:=False
    Selection.End(xlDown).Select
    Range("B50001").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, -1).Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\user\Desktop\Test\ADLER JUNG.xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Sheets("Dump Data Here").Select
    Range("A1").Select
    Selection.AutoFilter
    Range("A1").Select
    Sheets("Summary").Select
    Range("A1").Select
         
' Aftab Currency Exchange Uk
 
    Range("B6").Select
    Sheets("Dump Data Here").Select
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$W$23916").AutoFilter Field:=4, Criteria1:= _
        "Aftab Currency Exchange Uk"
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Range("A1:W683").Select
    Selection.Columns.AutoFit
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A2").Select
    Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=50000, Trend:=False
    Selection.End(xlDown).Select
    Range("B50001").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, -1).Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\user\Desktop\Test\AFTAB CURRENCY EXCHANGE UK.xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Sheets("Dump Data Here").Select
    Range("A1").Select
    Selection.AutoFilter
    Range("A1").Select
    Sheets("Summary").Select
    Range("A1").Select
   
' Al Ansari Exchange Llc, Uae
 
    Range("B6").Select
    Sheets("Dump Data Here").Select
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$W$23916").AutoFilter Field:=4, Criteria1:= _
        "Al Ansari Exchange Llc, Uae"
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Range("A1:W683").Select
    Selection.Columns.AutoFit
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A2").Select
    Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=50000, Trend:=False
    Selection.End(xlDown).Select
    Range("B50001").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, -1).Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\user\Desktop\Test\AL ANSARI EXCHANGE LLC, UAE.xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Sheets("Dump Data Here").Select
    Range("A1").Select
    Selection.AutoFilter
    Range("A1").Select
    Sheets("Summary").Select
    Range("A1").Select
   
' Al Zaman Exchange
 
    Range("B6").Select
    Sheets("Dump Data Here").Select
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$W$23916").AutoFilter Field:=4, Criteria1:= _
        "Al Zaman Exchange"
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Range("A1:W683").Select
    Selection.Columns.AutoFit
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A2").Select
    Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=50000, Trend:=False
    Selection.End(xlDown).Select
    Range("B50001").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, -1).Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\user\Desktop\Test\AL ZAMAN EXCHANGE.xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Sheets("Dump Data Here").Select
    Range("A1").Select
    Selection.AutoFilter
    Range("A1").Select
    Sheets("Summary").Select
    Range("A1").Select
 
End Sub
 
Last edited:

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sort by date Sort by votes
What cells in the summary sheet do you need to lookat for
Adler Jung, Aftab Currency Exchange Uk etc?
 
Upvote 0
Fluff said:
What cells in the summary sheet do you need to lookat for
Adler Jung, Aftab Currency Exchange Uk etc?
Click to expand...
the value mentioned I'm front of the name in another column
 
Upvote 0
What cells are they in? For instance
Adler Jung - look in F4
Aftab Currency Exchange Uk - look in F5
etc
 
Upvote 0
Yes. U r correct

The name is in column A4 and the value is in column F4
 
Last edited:
Upvote 0
In that case try
Code: 
Sub earthworm()
   Dim Ary As Variant
   Dim i As Long
   
   Ary = Array("Adler Jung", "[COLOR=#ff0000]F4[/COLOR]", "Aftab Currency Exchange Uk", "[COLOR=#ff0000]F5[/COLOR]", "Al Ansari Exchange Llc, Uae", "[COLOR=#ff0000]F6[/COLOR]", "Al Zaman Exchange", "[COLOR=#ff0000]F7[/COLOR]")
   For i = 0 To UBound(Ary) Step 2
      If Sheets("Summary").Range(Ary(i + 1)) <> 0 Then
         With Sheets("Dump")
            .Range("A1:W1").AutoFilter 4, Ary(i)
            .AutoFilter.Range.EntireRow.Copy
            .AutoFilterMode = False
         End With
         With Workbooks.Add
            With .Sheets(1)
               .Range("A1").PasteSpecial xlPasteFormats
               .Range("A1").PasteSpecial xlPasteValues
               .Columns.AutoFit
               With .Range("A2", .Range("B" & Rows.Count).End(xlUp).Offset(, -1))
                  .Value = Evaluate("if({1},row(" & .Address & ")-1)")
               End With
            End With
            Application.CutCopyMode = False
            .SaveAs FileName:= _
              Environ("userprofile") & "\Desktop\Test\" & Ary(i), FileFormat:=51
            .Close False
         End With
      End If
   Next i
End Sub
Ranges in red need to match the range for that criteria.
 
Upvote 0
I need to understand the logic . Please assist.
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Insert formula in last column macro
2
Replies
13
Views
215
MARK858
MARK858
S
  • Question Question
Dynamic Address by VBA
Replies
8
Views
212
MikeVol
MikeVol
R
  • Solved
Retype Macro to run properly
2
Replies
11
Views
144
Alex Blakenburg
A
E
  • Solved
macro for copying values to the next blank cell
Replies
5
Views
462
Micron
M
C
  • Question Question
Please help clean up my convoluted VBA code. It seems very redundant and repetitive.
Replies
1
Views
441
myall_blues
myall_blues

Forum statistics

Threads
1,224,823
Messages
6,181,171
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top