Free Microsoft Excel 2013 Quick Reference

Activate entire row of selected cell Results

Hi all,
I have posted before and you have been of great help. I am
relatively new at programming and working to piece together a program
to sort through a very large database. Based on one cells value being
even or odd, I need to then move that entire row to another worksheet.
Here is my programming, thanks for your time:

Sub WIDSSORT()
Worksheets("Sheet2").Activate
For Each c In Worksheets("Sheet2").Range("E2:E11450").Cells
If c.Value / 2 Mod 0 = 1 Then
GoTo moveroweven
Else:
GoTo moverowodd
End If
Next
On Error Resume Next
moveroweven:
good = Rows.Active
Rows(good).Cut
Sheet57.Activate
rowtomoveto = Str(Trim(Sheet57.UsedRange.Rows.Count + 1))
Rows(rowtomoveto).Select
ActiveSheet.Paste

moverowodd:
good = Rows.Active
Rows(good).Cut
Sheet3.Activate
rowtomoveto = Str(Trim(Sheet3.UsedRange.Rows.Count + 1))
Rows(rowtomoveto).Select
ActiveSheet.Paste

End Sub

I am trying to use Vlookup and want the "Lookup_value" to be the Active Row in which the curser is currently in. In row 1 of the active sheet, I am wanting the matching record from the previous sheet "VL20114th" to populate the entire row 1 when any of the cells in the active sheet are selected.

I thinking something like =VLOOKUP(INDIRECT("D"&ROW()),VL20114th,18,FALSE) But am having no luck. I would be happy with either formulas in each cell of row 1 or VBA. Any asisstance would be great

Hi,

I have the following piece of code which adds a user entered number of rows to a worksheet. However, as I already have one row in existance (which it copies x times) I'd like it to take one off the total entered by the user as it means I end up with one row more than is required.

Im sure it's simple enough and i've tried my best to work it out on my own,but just end up with some runtime errors....(I set i to -1 but im guessing that's a schoolboy error!)

Private Sub CommandButton1_Click()

'adds desired # of lines below the current line and
' copies the formulas to that/those lines
'added selection of more than one worksheet

Dim vRows As Long
Dim sht As Worksheet, shts() As String, i As Long

' row selection based on active cell --

ActiveCell.EntireRow.Select
vRows = _
Application.InputBox(prompt:= _
"How many students are taking this (shared) module?", Title:="Add Rows", _
Default:=0, Type:=1) 'type 1 is number

If vRows = False Then Exit Sub
'if you just want to add cells and not entire rows
' then delete ".EntireRow" in the following line

ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
Windows(1).SelectedSheets.Count)
i = 0

'insert rows on grouped worksheets

For Each sht In _
Application.ActiveWorkbook.Windows(1).SelectedSheets
Sheets(sht.Name).Select
i = i + 1
shts(i) = sht.Name

Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
Resize(rowsize:=vRows).Insert Shift:=xlDown
Selection.AutoFill Selection.Resize(rowsize:=vRows + 1), _
xlFillDefault
On Error Resume Next
' to remove the non-formulas
Selection.Offset(1).Resize(vRows).EntireRow. _
SpecialCells(xlConstants).ClearContents
Next sht

'reselect original group
Worksheets(shts).Select


End Sub


This is what I am trying to do

I have a table that's generated from access, and want to use a micro to create the pivot table for me.
Each week there will be more rows added or removed to the project so that's where I am having trouble selecting the range of the pivot table.

Here are the steps I take to create the table
1) Delete the first 26 rows. ALWAYS THE SAME
2) Add a New Column and called it Project can CONCATENATE the first two columns (carry formula for entire column)
3) Add a new column called filter and use a if function (carry formula for entire column)
4) create pivot table
5) Drag in fields i need for the pivot table
6) Now this is also where I have trouble as well, sort the total saving from highest to lowest and select the condition formatting with the red data bar for the total saving by owner.

Here is the macro I created using the recording feature
Sub pivottable()
'
' pivottable Macro
'

'
    Rows("1:26").Select
    Selection.Delete Shift:=xlUp
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Project"
    With ActiveCell.Characters(Start:=1, Length:=7).Font
        .Name = "Arial"
        .FontStyle = "Bold"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-2], "" - "",RC[-1])"
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C1427"), Type:=xlFillDefault
    Range("C2:C1427").Select
    ActiveWindow.ScrollRow = 1401
    ActiveWindow.ScrollRow = 1399
    ActiveWindow.ScrollRow = 1397
    ActiveWindow.ScrollRow = 1390
    ActiveWindow.ScrollRow = 1375
    ActiveWindow.ScrollRow = 1340
    ActiveWindow.ScrollRow = 1295
    ActiveWindow.ScrollRow = 1168
    ActiveWindow.ScrollRow = 1001
    ActiveWindow.ScrollRow = 811
    ActiveWindow.ScrollRow = 707
    ActiveWindow.ScrollRow = 541
    ActiveWindow.ScrollRow = 379
    ActiveWindow.ScrollRow = 323
    ActiveWindow.ScrollRow = 250
    ActiveWindow.ScrollRow = 226
    ActiveWindow.ScrollRow = 198
    ActiveWindow.ScrollRow = 189
    ActiveWindow.ScrollRow = 185
    ActiveWindow.ScrollRow = 183
    ActiveWindow.ScrollRow = 182
    ActiveWindow.ScrollRow = 178
    ActiveWindow.ScrollRow = 176
    ActiveWindow.ScrollRow = 172
    ActiveWindow.ScrollRow = 167
    ActiveWindow.ScrollRow = 157
    ActiveWindow.ScrollRow = 152
    ActiveWindow.ScrollRow = 146
    ActiveWindow.ScrollRow = 141
    ActiveWindow.ScrollRow = 133
    ActiveWindow.ScrollRow = 120
    ActiveWindow.ScrollRow = 115
    ActiveWindow.ScrollRow = 109
    ActiveWindow.ScrollRow = 92
    ActiveWindow.ScrollRow = 77
    ActiveWindow.ScrollRow = 57
    ActiveWindow.ScrollRow = 38
    ActiveWindow.ScrollRow = 21
    ActiveWindow.ScrollRow = 3
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 16
    ActiveWindow.ScrollColumn = 17
    ActiveWindow.ScrollColumn = 18
    ActiveWindow.ScrollColumn = 19
    ActiveWindow.ScrollColumn = 20
    ActiveWindow.ScrollColumn = 21
    ActiveWindow.ScrollColumn = 22
    ActiveWindow.ScrollColumn = 23
    ActiveWindow.ScrollColumn = 24
    ActiveWindow.ScrollColumn = 25
    ActiveWindow.ScrollColumn = 26
    ActiveWindow.ScrollColumn = 27
    ActiveWindow.ScrollColumn = 28
    ActiveWindow.ScrollColumn = 29
    ActiveWindow.ScrollColumn = 30
    Columns("AL:AL").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("AL1").Select
    ActiveCell.FormulaR1C1 = "Filter"
    With ActiveCell.Characters(Start:=1, Length:=6).Font
        .Name = "Arial"
        .FontStyle = "Bold"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("AL2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[28]=RC[56],1,0)"
    Range("AL3").Select
    ActiveWindow.SmallScroll ToRight:=-3
    Range("AL2").Select
    Selection.AutoFill Destination:=Range("AL2:AL1427"), Type:=xlFillDefault
    Range("AL2:AL1427").Select
    ActiveWindow.ScrollColumn = 34
    ActiveWindow.ScrollColumn = 33
    ActiveWindow.ScrollColumn = 30
    ActiveWindow.ScrollColumn = 22
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1395
    ActiveWindow.ScrollRow = 1390
    ActiveWindow.ScrollRow = 1379
    ActiveWindow.ScrollRow = 1364
    ActiveWindow.ScrollRow = 1313
    ActiveWindow.ScrollRow = 1163
    ActiveWindow.ScrollRow = 909
    ActiveWindow.ScrollRow = 667
    ActiveWindow.ScrollRow = 526
    ActiveWindow.ScrollRow = 371
    ActiveWindow.ScrollRow = 167
    ActiveWindow.ScrollRow = 81
    ActiveWindow.ScrollRow = 1
    Range("A1").Select
    Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Finance!R1C1:R1427C289", Version:=xlPivotTableVersion12).CreatePivotTable _
        TableDestination:="Sheet2!R3C1", TableName:="PivotTable1", DefaultVersion _
        :=xlPivotTableVersion12
    Sheets("Sheet2").Select
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Project")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Owner")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Location")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
        "Financial Classification")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Status")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Filter")
        .Orientation = xlPageField
        .Position = 1
    End With
    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
        "PivotTable1").PivotFields("Total (Savings)"), "Sum Total (Savings)", _
        xlSum
    ActiveSheet.PivotTables("PivotTable1").RowAxisLayout xlOutlineRow
    ActiveSheet.PivotTables("PivotTable1").SubtotalLocation = xlAtBottom
    Columns("A:A").EntireColumn.AutoFit
    ActiveWindow.SmallScroll ToRight:=2
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.Zoom = 85
    ActiveWindow.Zoom = 70
    Range("B11:C257").Select
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Project").AutoSort _
        xlDescending, "Sum of Total (Savings)"
    Range("C11:C257").Select
    Selection.FormatConditions.AddDatabar
    Selection.FormatConditions(Selection.FormatConditions.Count).ShowValue = True
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .MinPoint.Modify newtype:=xlConditionValueLowestValue
        .MaxPoint.Modify newtype:=xlConditionValueHighestValue
    End With
    With Selection.FormatConditions(1).BarColor
        .Color = 5920255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).ScopeType = xlSelectionScope
    Selection.FormatConditions(1).ScopeType = xlFieldsScope
    ActiveWindow.ScrollRow = 197
    ActiveWindow.ScrollRow = 195
    ActiveWindow.ScrollRow = 188
    ActiveWindow.ScrollRow = 184
    ActiveWindow.ScrollRow = 180
    ActiveWindow.ScrollRow = 174
    ActiveWindow.ScrollRow = 168
    ActiveWindow.ScrollRow = 162
    ActiveWindow.ScrollRow = 150
    ActiveWindow.ScrollRow = 136
    ActiveWindow.ScrollRow = 114
    ActiveWindow.ScrollRow = 98
    ActiveWindow.ScrollRow = 82
    ActiveWindow.ScrollRow = 72
    ActiveWindow.ScrollRow = 63
    ActiveWindow.ScrollRow = 53
    ActiveWindow.ScrollRow = 49
    ActiveWindow.ScrollRow = 41
    ActiveWindow.ScrollRow = 37
    ActiveWindow.ScrollRow = 31
    ActiveWindow.ScrollRow = 21
    ActiveWindow.ScrollRow = 15
    ActiveWindow.ScrollRow = 11
    ActiveWindow.ScrollRow = 7
    ActiveWindow.ScrollRow = 1
    Columns("C:C").Select
    Selection.NumberFormat = "$#,##0.00"
    Selection.NumberFormat = "$#,##0.0"
    Selection.NumberFormat = "$#,##0"
End Sub


I found this macro through the forum (thanks)
it inserts a row or rows, then copies the formulas from the row above - but is then supposed to delete all of the values (but not formulas)
for example: I enter the date (A1) my expected revenue (B1) then formulas calculated the next cells.
I want the macro to create row B with B1 & B2 empty but the formulas in B3...
Here is the macro.
Sub InsertRow(Optional vRows As Long = 0)
' Documented:  http://www.mvps.org/dmcritchie/excel/insrtrow.htm
' Re: Insert Rows --   1997/09/24 Mark Hill <markhill@charm.net.noSpam>
   ' row selection based on active cell -- rev. 2000-09-02 David McRitchie
   Dim x As Long
   ActiveCell.EntireRow.Select  'So you do not have to preselect entire row
   If vRows = 0 Then
    vRows = Application.InputBox(prompt:= _
      "How many rows do you want to add?", Title:="Add Rows", _
      Default:=1, Type:=1) 'Default for 1 row, type 1 is number
    If vRows = False Then Exit Sub
   End If

   'if you just want to add cells and not entire rows
   'then delete ".EntireRow" in the following line

   'rev. 2001-01-17 Gary L. Brown, programming, Grouped sheets
   Dim sht As Worksheet, shts() As String, i As Long
   ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
       Windows(1).SelectedSheets.Count)
   i = 0
   For Each sht In _
       Application.ActiveWorkbook.Windows(1).SelectedSheets
    Sheets(sht.Name).Select
    i = i + 1
    shts(i) = sht.Name

    x = Sheets(sht.Name).UsedRange.Rows.Count 'lastcell fixup

    Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
     Resize(rowsize:=vRows).Insert Shift:=xlDown

    Selection.AutoFill Selection.Resize( _
     rowsize:=vRows + 1), xlFillDefault

    On Error Resume Next    'to handle no constants in range -- John McKee 2000/02/01
    ' to remove the non-formulas -- 1998/03/11 Bill Manville
    Selection.Offset(1).Resize(vRows).EntireRow. _
     SpecialCells(xlConstants).ClearContents
   Next sht
   Worksheets(shts).Select
End Sub
It works great - but the values are copied. Did I miss something?

Thanks for the help.

Hi forum gurus,

I have a worksheet that needs to have its data re-orderd. This seems pretty straight forward, but I'm stumpped on how to use a found cell as the upper limit for another search range.

Basically, I want to find the word "Comment" within (:=xlPart) the text string of header-row cells. When the string "Comment" is found, then I want to look down that column to see if any actual comments are present (four or more letters-- What:="????*").
- If not, then continue to the next column where "Comment" is found in the header.
- If so, then cut the entire column and insert it (sequentially for multiple finds) after column ("H"); then continue to the next column where "Comment" is found in the header and repeat.

I get to the point of selecting the column range I want to search for actual comments, but then my search for comments looks across that row, instead of looking down the column. Here is my annotated vba code:

 Sub LastFndCmmt()
  'Almost works
   Const sFind As String = "Comment"
    Dim ColRng As Long
    Dim LastCol As Integer
    Dim LastRow As Long
        npaste = 1
    
'  Establish limits of data
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Cells(Cells.Rows.Count, "C").End(xlUp).Row

' Search for "Comment" string in header row
    For ColRng = 1 To LastCol
        Cells.Find(What:=sFind, After:=Range("H1").Offset(0, npaste + 2), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
       False, SearchFormat:=False).Activate

'begin next search one cell down so that the header string is not part of the search range
        ActiveCell.Offset(1, 0).Select

'Use selected cell as uppermost limit for a range to lastrow of that column
        Range(ActiveCell, ActiveCell.End(xlDown)).Select

'Search down the range for any text string with 4 or more characters
        With ActiveRange
            Cells.Find(What:="????*", After:=ActiveCell, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).EntireColumn.Select

' If a text string is found, then cut the entire column
            If Not Cells Is Nothing Then
                Selection.Cut

' Insert the cut column in successive columns following column "H"
            Columns("H:H").Offset(0, npaste).Select
            Selection.Insert Shift:=xlToRight
            npaste = npaste + 1
               End If
        End With
   Next
End Sub
Thanks very much in advance....

TucsonJack

Ok so for the past couple weeks i have been trying to design an inventory system for my Jr. Co-op position in college. Visual basic is new to me within the past year. Between searching / posting through forums and going thru textbooks i have designed the following system. i have one VBA script on each worksheet with multiple ranges that get searched for a value <= 5 , or 10, or whatever depending on what is withing the selected range. the code im using looks like this
Sub turning_inserts()
    
Dim cell As Range
Dim NewRange As Range
Dim MyCount As Long
    MyCount = 1
    For Each cell In Range("E8:E24")
        If cell.Value <> "" Then
            If cell.Value <= 5 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
    For Each cell In Range("E31:E46")
        If cell.Value <> "" Then
            If cell.Value <= 10 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
    For Each cell In Range("E53:E68")
        If cell.Value <> "" Then
            If cell.Value <= 15 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
    For Each cell In Range("E75:E93")
        If cell.Value <> "" Then
            If cell.Value <= 8 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
    For Each cell In Range("K8:K24")
        If cell.Value <> "" Then
            If cell.Value <= 10 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
    For Each cell In Range("K31:K46")
        If cell.Value <> "" Then
            If cell.Value <= 20 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
        For Each cell In Range("K53:K68")
        If cell.Value <> "" Then
            If cell.Value <= 5 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
    For Each cell In Range("K75:K93")
        If cell.Value <> "" Then
            If cell.Value <= 10 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
    For Each cell In Range("Q8:Q24")
        If cell.Value <> "" Then
            If cell.Value <= 15 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
    For Each cell In Range("Q31:Q46")
        If cell.Value <> "" Then
            If cell.Value <= 8 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
    For Each cell In Range("Q53:Q68")
        If cell.Value <> "" Then
            If cell.Value <= 10 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
    For Each cell In Range("Q75:Q93")
        If cell.Value <> "" Then
            If cell.Value <= 20 Then
                If MyCount = 1 Then Set NewRange = cell
                Set NewRange = Application.Union(NewRange, cell)
                MyCount = MyCount + 1
            End If
        End If
    Next cell
    NewRange.Interior.ColorIndex = 3
End Sub
So as you can see there are different minimum values set to highlight cells in the ranges.
so you can see what it highlights here is an acocmpanied picture of the worksheet this code is from
http://i42.tinypic.com/2wfo2ol.jpg
So my question is this. i want to take all data from the "Item #" columns that has a corresponding red quantity value and place the item #s into a seperate sheet. i want it to search the ENTIRE workbook and compile them all in a list.
this is the code i have to do that currently, but all it does is open a sheet with nothing in it. what am i missing
Sub Macro1()
Dim thiswb As Workbook
Dim newwb As Workbook
Dim sh As Worksheet
Dim iCol As Long
Set thiswb = ActiveWorkbook
Set newwb = Workbooks.Add
thiswb.Activate
k = 1
For Each sh In Worksheets
    sh.Activate
    Range("A1").Select
    
    'find quantity in row 1 and store column number
    Dim Found As Range, LastRow As Long
    Set Found = Rows(1).Find(what:="Quantity", LookIn:=xlValues, lookat:=xlWhole)
    If Found Is Nothing Then Exit Sub
    LastRow = Cells(Rows.Count, Found.Column).End(xlUp).Row
    
    j = 1
    For i = LastRow To 2 Step -1
        If Cells(i, Found.Column).Interior.ColorIndex = 3 Then
            Cells(i, 1).Copy
            newwb.Activate
            Sheets(k).Select
            Cells(j, 1).Select
            ActiveSheet.Paste
            j = j + 1
            thiswb.Activate
            sh.Select
        End If
    Next i
    k = k + 1
Next sh
End Sub
Any help from VBA pro's will be very appreciated thanks to everybody in advance if you can help me.

I have a pretty big task in mind, and I'm stuck on a lot of parts. I've outlined it below:

1. search for a specific phrase in the spreadsheet (exact phrase, match entire cell contents). Store its index.

This is easy enough:

	VB:
	
Cells.Find(What:="Vendor Terminal p/n", After:=ActiveCell, LookIn:= _        xlFormulas, LookAt:=xlWhole,
SearchOrder:=xlByRows, SearchDirection:= _ 
xlNext, MatchCase:=True, SearchFormat:=False).Activate 
index = activecell.row 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
2. Use a Do While loop to find the index of the last non-empty cell in the range (index to the end of the column). Call it index2.

This is the part that's giving me troubles; I'm pretty sure that I should use Do While and xlDown, but I'm not at all sure HOW to implement this. Anybody have suggestions? I appreciate it!

3. Use this range to select the items in the column between the first index and the second index, and then copy the data in this range to a new spreadsheet. Save this spreadsheet as 'doc1.xlsx.'

4. Repeat the process, except now APPEND the items in the range to doc1.xlsx.

I have been working trying to speed this macro up as it processes 14000+ rows of data X 59 columns. By chance, I went to stop execution of the macro by pressing escape twice but only pressed it once and the macro increased speed significantly. The workbook "Consolidated Usage For DC.xls" has two worksheets, one named "Field" and one named "DC". Each worksheet is a list of part numbers in column "A" followed by 7 columns of information, then 52 columns(weeks) of consumption data. The macro basically looks at the first part on the "Field" worksheet, checks to see if it is on the "DC" worksheet. If it is, it then combines the consumption data each week and overwrites it on the "DC" worksheet. If the part is not found on "DC" worksheet, it appends the entire row from the "Field" worksheet to the bottom of the "DC" worksheet. Then it proceeds to the second part on the "Field" worksheet and so on....

Can someone help me understand why hitting the escape key once during execution speeds it up considerably? I added this in the code to see if it would simulate the key stroke but no luck.

	VB:
	
Application.OnKey "{esc}" 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Any help appreciated. Thanks!


	VB:
	
 Combine_FCandDC() 
    Dim partnum As String 
    Dim fldvalue() As Integer 
    Dim dcvalue() As Integer 
    Dim total As Long 
    Dim lastrow As Long 
    Dim ACell As String 
    Dim Col As String 
    Dim answer As String 
    Dim Mynote As String 
    Dim rng As Range 
    Dim wbook As Workbook 
    Dim Icount As Integer 
    Dim Step As Integer 
    Dim xcalc As XlCalculation 
    With Application 
        xcalc = .Calculation 
        .Calculation = xlCalculationManual 
        .EnableEvents = False 
        .ScreenUpdating = False 
    End With 
     'test if file is open/present
    On Error Resume Next 
    Set wbook = Workbooks("Consolidated Usage For DC.xls") 
    If wbook Is Nothing Then 
        Mynote = "Have you saved the uncombined inventory workbook to the Inventory Level Setting Utility Folder?" 
        answer = MsgBox(Mynote, vbQuestion + vbYesNo, "Combine Counts Utility") 
        If answer = vbNo Then 
            MsgBox ("Be sure and save file as [Consolidated Usage For DC.xls]") 
            Exit Sub 
        Else 
            wbook.Activate 
        End If 
        ChDir ThisWorkbook.Path 
        Workbooks.Open Filename:="Consolidated Usage For DC.xls" 
        Workbooks("Consolidated Usage For DC.xls").Activate 
        Worksheets("DC").Activate 
         'test to see if file has been processed
        Range("A1").Select 
    End If 
    Workbooks("Consolidated Usage For DC.xls").Activate 
    Worksheets("DC").Activate 
    Range("A1").Select 
    If ActiveCell.Value  "Material" Then 
        MsgBox ("The consumption file has already been combined. Please check status of the file to validate next steps.") 
        Exit Sub 
    Else 
        Application.StatusBar = "Combining Field and Sales Consumption - This may take up to 20 minutes depending on the
number of parts." 
        Application.OnKey "{esc}" 
        Worksheets("Field").Activate 
         'format columms with pastespecial
        Range("ED1").Select 
        Selection.Copy 
        Columns("A:A").Select 
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:=False, Transpose:=False 
        Worksheets("DC").Activate 
        Range("ED1").Select 
        Selection.Copy 
        Columns("A:A").Select 
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:=False, Transpose:=False 
         
         'begin combining of consumption
        Worksheets("Field").Activate 
        Range("A1").Select 
        With ActiveSheet 
            lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row 
        End With 
        Redim fldvalue(1 To lastrow) 
        Redim dcvalue(1 To lastrow) 
    End If 
    For Step = 1 To lastrow 
        ActiveCell.Offset(1, 0).Activate 
        partnum = ActiveCell.Value 
         
        Worksheets("DC").Activate 
        Range("A1").Select 
         
        Set rfound = Cells.Find(what:=partnum, After:=ActiveCell, LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlColumns,
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) 
         
        If Not rfound Is Nothing Then 
            Application.Goto rfound, True 
             'if found
            Worksheets("Field").Activate 
            ActiveCell.Offset(0, 7).Select 
            For Icount = 1 To 52 
                ActiveCell.Offset(0, 1).Activate 
                fldvalue(Icount) = ActiveCell.Value 
            Next Icount 
            ActiveCell.Offset(0, -59).Activate 
             
             
            Worksheets("DC").Activate 
            ActiveCell.Offset(0, 7).Select 
            For Icount = 1 To 52 
                ActiveCell.Offset(0, 1).Activate 
                dcvalue(Icount) = ActiveCell.Value 
                total = fldvalue(Icount) + dcvalue(Icount) 
                ActiveCell.Value = total 
            Next Icount 
            ActiveCell.Offset(0, -52).Activate 
             
             
            Worksheets("Field").Activate 
        Else 
             'if not found
            Worksheets("DC").Activate 
            lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1 
            Worksheets("Field").Activate 
            Worksheets("DC").Range("A" & lastrow, "BH" & lastrow) = Worksheets("Field").Range(ActiveCell,
ActiveCell.Offset(0, 59)).Value 
        End If 
         'remove "0's"
    Next Step 
    Worksheets("Field").Activate 
    Worksheets("DC").Activate 
    For Each rng In Range("I2", "BH" & lastrow) ' substitute your range here
        If rng.Value = 0 Then 
            rng.Value = "" 
        End If 
    Next 
    Worksheets("DC").Activate 
     
    Count = start 
    Columns("A:H").Select 
    Selection.NumberFormat = "General" 
    lastrow = WorksheetFunction.Max(Range("A65536").End(xlUp).Row) 
     
    Columns("B:B").Select 
    Selection.NumberFormat = "General" 
    Columns("C:C").Select 
    Selection.NumberFormat = "General" 
    Columns("D:D").Select 
    Selection.NumberFormat = "General" 
    Columns("E:E").Select 
    Selection.NumberFormat = "General" 
    Columns("F:F").Select 
    Selection.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" 
    Columns("G:G").Select 
    Selection.NumberFormat = "General" 
    Columns("H:H").Select 
    Selection.NumberFormat = "General" 
    Cells.Select 
    Cells.EntireColumn.AutoFit 
    Cells.Select 
    Selection.Copy 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
    Sheets("Field").Select 
     
    With Application 
        .Calculation = xcalc 
         
        .EnableEvents = True 
        .ScreenUpdating = True 
    End With 
    DeleteErrors 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hi,

I have set up some code to search for a value, in this case a number, copy all matching data to another sheet, edit it then copy some values to another sheet. I then want to go back to the original sheet and search for a different value and do similar actions then onto the third and fourth.
The code i have works fine for the first value then does nothing for the rest.
I have tried searching and i can't find anything on this does anyone have any ideas??

the code i have is

	VB:
	
Sheets("SAP data").Select 
 'to copy 30010's time
Dim LSearchRow As Integer 
Dim LCutToRow As Integer 
 'Start search in row 1
LSearchRow = 1 
 'Start copying data to row 2 in Sheet1 (row counter variable)
LCutToRow = 1 
While Len(Range("A" & CStr(LSearchRow)).Value) > 0 
     'If value in column A = "00030010", copy entire row to Sheet1
    If Range("A" & CStr(LSearchRow)).Value = "00030010" Then 
         'Select row in SAP data to copy
        Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select 
        Selection.Cut 
         'Paste row into Sheet1 in next row
        Sheets("Sheet1").Select 
        Rows(CStr(LCutToRow) & ":" & CStr(LCutToRow)).Select 
        ActiveSheet.Paste 
         'Move counter to next row
        LCutToRow = LCutToRow + 1 
         'Go back to SAP data to continue searching
        Sheets("SAP data").Select 
    End If 
    LSearchRow = LSearchRow + 1 
Wend 
 'Position on cell A3
Application.CutCopyMode = False 
Range("A3").Select 
 'to edit their data
Sheets("Sheet1").Select 
 'convert time
Columns("J:J").Select 
Application.CutCopyMode = False 
Selection.Insert Shift:=xlToRight 
Range("J1").Select 
ActiveCell.FormulaR1C1 = "=RC[-1]/24" 
Selection.AutoFill Destination:=Range("J1:J100"), Type:=xlFillDefault 
Columns("J:J").Select 
Selection.NumberFormat = "h:mm" 
 'remove index from part number
Columns("F:F").Select 
Application.CutCopyMode = False 
Selection.Insert Shift:=xlToRight 
Columns("F:F").Select 
Selection.NumberFormat = "General" 
Range("F1").Select 
ActiveCell.FormulaR1C1 = "=MID(RC[-1],1,LEN(RC[-1])-4)" 
Selection.AutoFill Destination:=Range("F1:F100"), Type:=xlFillDefault 
 'combine material and op numbers
Range("G1").Select 
Do While ActiveCell  "" 'Loops until the active cell is blank
    ActiveCell.Offset(0, 7).Formula = _ 
    ActiveCell.Offset(0, -1) & " " & ActiveCell.Offset(0, 0) 
    ActiveCell.Offset(1, 0).Select 
Loop 
Columns("B:I").Select 
Selection.Delete Shift:=xlToLeft 
Columns("D:E").Select 
Selection.Delete Shift:=xlToLeft 
Rows("1:1").Select 
Selection.Insert Shift:=xlDown 
Range("A1").Select 
ActiveCell.FormulaR1C1 = "CC" 
Range("B1").Select 
ActiveCell.FormulaR1C1 = "OT" 
Range("C1").Select 
ActiveCell.FormulaR1C1 = "NT" 
Range("D1").Select 
ActiveCell.FormulaR1C1 = "PON" 
Range("D2").Select 
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _ 
"Sheet1!R1C1:R101C4").CreatePivotTable TableDestination:= _ 
"'[T5 matrix1.xls]Sheet1'!R1C6", TableName:="PivotTable3", DefaultVersion:= _ 
xlPivotTableVersion10 
ActiveSheet.PivotTables("PivotTable3").AddDataField ActiveSheet.PivotTables( _ 
"PivotTable3").PivotFields("NT"), "Count of NT", xlCount 
With ActiveSheet.PivotTables("PivotTable3").PivotFields("PON") 
    .Orientation = xlRowField 
    .Position = 1 
End With 
Range("F1").Select 
ActiveSheet.PivotTables("PivotTable3").PivotFields("Count of NT").Function = _ 
xlSum 
Range("G3:G30").Select 
Selection.NumberFormat = "h:mm" 
Columns("A:D").Select 
Selection.Delete Shift:=xlToLeft 
 
 
Dim rngCell As Range 
 
Sheets("Sheet1").Select 
On Error Resume Next 
Set rngCell = _ 
Cells.Find(What:="915833 0010", After:=ActiveCell, LookIn:=xlFormulas, _ 
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
MatchCase:=False, SearchFormat:=False) 
Err.Clear: On Error Goto -1: On Error Goto 0 
If Not rngCell Is Nothing Then 
    rngCell.Activate 
    ActiveCell.Offset(0, 1).Copy 
    Sheets("Skill matrix").Select 
    Cells.Find(What:="30010", After:=ActiveCell, LookIn:=xlFormulas, LookAt _ 
    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ 
    False, SearchFormat:=False).Activate 
    ActiveCell.Offset(5, 0).Activate 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks:= _ 
    False, Transpose:=False 
    Set rngCell = Nothing 
End If 
 
 
Sheets("Sheet1").Select 
On Error Resume Next 
Set rngCell = _ 
Cells.Find(What:="915833 0011", After:=ActiveCell, LookIn:=xlFormulas, _ 
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
MatchCase:=False, SearchFormat:=False) 
Err.Clear: On Error Goto -1: On Error Goto 0 
If Not rngCell Is Nothing Then 
    rngCell.Activate 
    ActiveCell.Offset(0, 1).Copy 
    Sheets("Skill matrix").Select 
    Cells.Find(What:="30010", After:=ActiveCell, LookIn:=xlFormulas, LookAt _ 
    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ 
    False, SearchFormat:=False).Activate 
    ActiveCell.Offset(8, 0).Activate 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks:= _ 
    False, Transpose:=False 
    Set rngCell = Nothing 
End If 
 
 'to copy 30013's time
Sheets("SAP data").Select 
 'Start search in row 1
LSearchRow = 1 
 'Start copying data to row 2 in Sheet1 (row counter variable)
LCutToRow = 1 
While Len(Range("A" & CStr(LSearchRow)).Value) > 0 
     'If value in column A = "00030013", copy entire row to Sheet1
    If Range("A" & CStr(LSearchRow)).Value = "00030013" Then 
         'Select row in SAP data to copy
        Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select 
        Selection.Cut 
         'Paste row into Sheet1 in next row
        Sheets("Sheet1").Select 
        Rows(CStr(LCutToRow) & ":" & CStr(LCutToRow)).Select 
        ActiveSheet.Paste 
         'Move counter to next row
        LCutToRow = LCutToRow + 1 
         'Go back to SAP data to continue searching
        Sheets("SAP data").Select 
    End If 
    LSearchRowz = LSearchRow + 1 
Wend 
 'Position on cell A3
Application.CutCopyMode = False 
Range("A3").Select 
 'to edit their data
Sheets("Sheet1").Select 
 'convert time
Columns("J:J").Select 
Application.CutCopyMode = False 
Selection.Insert Shift:=xlToRight 
Range("J1").Select 
ActiveCell.FormulaR1C1 = "=RC[-1]/24" 
Selection.AutoFill Destination:=Range("J1:J100"), Type:=xlFillDefault 
Columns("J:J").Select 
Selection.NumberFormat = "h:mm" 
 'remove index from part number
Columns("F:F").Select 
Application.CutCopyMode = False 
Selection.Insert Shift:=xlToRight 
Columns("F:F").Select 
Selection.NumberFormat = "General" 
Range("F1").Select 
ActiveCell.FormulaR1C1 = "=MID(RC[-1],1,LEN(RC[-1])-4)" 
Selection.AutoFill Destination:=Range("F1:F100"), Type:=xlFillDefault 
 'combine material and op numbers
Range("G1").Select 
Do While ActiveCell  "" 'Loops until the active cell is blank
    ActiveCell.Offset(0, 7).Formula = _ 
    ActiveCell.Offset(0, -1) & " " & ActiveCell.Offset(0, 0) 
    ActiveCell.Offset(1, 0).Select 
Loop 
Columns("B:I").Select 
Selection.Delete Shift:=xlToLeft 
Columns("D:E").Select 
Selection.Delete Shift:=xlToLeft 
Rows("1:1").Select 
Selection.Insert Shift:=xlDown 
Range("A1").Select 
ActiveCell.FormulaR1C1 = "CC" 
Range("B1").Select 
ActiveCell.FormulaR1C1 = "OT" 
Range("C1").Select 
ActiveCell.FormulaR1C1 = "NT" 
Range("D1").Select 
ActiveCell.FormulaR1C1 = "PON" 
Range("D2").Select 
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _ 
"Sheet1!R1C1:R101C4").CreatePivotTable TableDestination:= _ 
"'[T5 matrix1.xls]Sheet1'!R1C6", TableName:="PivotTable3", DefaultVersion:= _ 
xlPivotTableVersion10 
ActiveSheet.PivotTables("PivotTable3").AddDataField ActiveSheet.PivotTables( _ 
"PivotTable3").PivotFields("NT"), "Count of NT", xlCount 
With ActiveSheet.PivotTables("PivotTable3").PivotFields("PON") 
    .Orientation = xlRowField 
    .Position = 1 
End With 
Range("F1").Select 
ActiveSheet.PivotTables("PivotTable3").PivotFields("Count of NT").Function = _ 
xlSum 
Range("G3:G30").Select 
Selection.NumberFormat = "h:mm" 
Columns("A:D").Select 
Selection.Delete Shift:=xlToLeft 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hi everyone,

I am trying to re engingeer the following code.

This looks at a range, copies all unique values into its own workbook and creates a directory for all of these new files when the Macro is run.

What I am looking for is instead of looking at a range in a specific Column, I need the macro to loop through a validation list and copy the entire sheet as opposed to a given range.

I have attached a test spreadshet


	VB:
	
 'This example will create a new folder for you and will create
 'a new workbook with the data of every unique value in this folder.
 'The workbooks will be saved with the Unique value in the new folder.
 'It will also add a worksheet to your workbook named "RDBLogSheet" with
 'hyperlinks to the workbooks so it is easy to open the workbooks.
 'Every time you run the macro it delete this worksheet first so the information is up to date.
 'Note: this example use the function LastRow in the ModReset module
Sub Copy_To_Workbooks() 
     'Note: This macro use the function LastRow
    Dim My_Range As Range 
    Dim FieldNum As Long 
    Dim FileExtStr As String 
    Dim FileFormatNum As Long 
    Dim CalcMode As Long 
    Dim ViewMode As Long 
    Dim ws2 As Worksheet 
    Dim MyPath As String 
    Dim foldername As String 
    Dim Lrow As Long 
    Dim cell As Range 
    Dim CCount As Long 
    Dim WSNew As Worksheet 
    Dim ErrNum As Long 
     'Set filter range on ActiveSheet: A11 is the top left cell of your filter range
     'and the header of the first column, D is the last column in the filter range.
     'You can also add the sheet name to the code like this :
     'Worksheets("Sheet1").Range("A11:D" & LastRow(Worksheets("Sheet1")))
     'No need that the sheet is active then when you run the macro when you use this.
    Set My_Range = Range("A11:D" & LastRow(ActiveSheet)) 
    My_Range.Parent.Select 
    If ActiveWorkbook.ProtectStructure = True Or _ 
    My_Range.Parent.ProtectContents = True Then 
        MsgBox "Sorry, not working when the workbook or worksheet is protected", _ 
        vbOKOnly, "Copy to new workbook" 
        Exit Sub 
    End If 
     'This example filters on the first column in the range(change the field if needed)
     'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
    FieldNum = 1 
     'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False 
     'Set the file extension/format
    If Val(Application.Version) < 12 Then 
         'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143 
    Else 
         'You use Excel 2007
        If ActiveWorkbook.FileFormat = 56 Then 
            FileExtStr = ".xls": FileFormatNum = 56 
        Else 
            FileExtStr = ".xlsx": FileFormatNum = 51 
        End If 
    End If 
     'Change ScreenUpdating, Calculation, EnableEvents, ....
    With Application 
        CalcMode = .Calculation 
        .Calculation = xlCalculationManual 
        .ScreenUpdating = False 
        .EnableEvents = False 
    End With 
    ViewMode = ActiveWindow.View 
    ActiveWindow.View = xlNormalView 
    ActiveSheet.DisplayPageBreaks = False 
     'Delete the sheet RDBLogSheet if it exists
    On Error Resume Next 
    Application.DisplayAlerts = False 
    Sheets("RDBLogSheet").Delete 
    Application.DisplayAlerts = True 
    On Error Goto 0 
     ' Add worksheet to copy/Paste the unique list
    Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count)) 
    ws2.Name = "RDBLogSheet" 
     'Fill in the pathfolder where you want the new folder with the files
     'you can use also this "C:UsersRontest"
    MyPath = Application.DefaultFilePath 
     'Add a slash at the end if the user forget it
    If Right(MyPath, 1)  "" Then 
        MyPath = MyPath & "" 
    End If 
     'Create folder for the new files
    foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "" 
    MkDir foldername 
    With ws2 
         'first we copy the Unique data from the filter field to ws2
        My_Range.Columns(FieldNum).AdvancedFilter _ 
        Action:=xlFilterCopy, _ 
        CopyToRange:=.Range("A3"), Unique:=True 
         'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row 
        For Each cell In .Range("A4:A" & Lrow) 
             'Filter the range
            My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _ 
            Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?") 
             'Check if there are no more then 8192 areas(limit of areas)
            CCount = 0 
            On Error Resume Next 
            CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _ 
            .Areas(1).Cells.Count 
            On Error Goto 0 
            If CCount = 0 Then 
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _ 
                & vbNewLine & "It is not possible to copy the visible data." _ 
                & vbNewLine & "Tip: Sort your data before you use this macro.", _ 
                vbOKOnly, "Split in worksheets" 
            Else 
                 'Add new workbook with one sheet
                Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
                 'Copy/paste the visible data to the new workbook
                My_Range.SpecialCells(xlCellTypeVisible).Copy 
                With WSNew.Range("A1") 
                     ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                     ' Remove this line if you use Excel 97
                    .PasteSpecial Paste:=8 
                    .PasteSpecial xlPasteValues 
                    .PasteSpecial xlPasteFormats 
                    Application.CutCopyMode = False 
                    .Select 
                End With 
                 'Save the file in the new folder and close it
                On Error Resume Next 
                WSNew.Parent.SaveAs foldername & _ 
                cell.Value & FileExtStr, FileFormatNum 
                If Err.Number > 0 Then 
                    Err.Clear 
                    ErrNum = ErrNum + 1 
                    WSNew.Parent.SaveAs foldername & _ 
                    "Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum 
                    .Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _ 
                    "Error_" & Format(ErrNum, "0000") & FileExtStr & """)" 
                    .Cells(cell.Row, "A").Interior.Color = vbRed 
                Else 
                    .Cells(cell.Row, "B").Formula = _ 
                    "=Hyperlink(""" & foldername & cell.Value & FileExtStr & """)" 
                End If 
                WSNew.Parent.Close False 
                On Error Goto 0 
            End If 
             'Show all the data in the range
            My_Range.AutoFilter Field:=FieldNum 
        Next cell 
        .Cells(1, "A").Value = "Red cell: can't use the Unique name as file name" 
        .Cells(1, "B").Value = "Created Files (Click on the link to open a file)" 
        .Cells(3, "A").Value = "Unique Values" 
        .Cells(3, "B").Value = "Full Path and File name" 
        .Cells(3, "A").Font.Bold = True 
        .Cells(3, "B").Font.Bold = True 
        .Columns("A:B").AutoFit 
    End With 
     'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False 
    If ErrNum > 0 Then 
        MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _ 
        & vbNewLine & "There are characters in the name that are not allowed" _ 
        & vbNewLine & "in a sheet name or the worksheet already exist." 
    End If 
     'Restore ScreenUpdating, Calculation, EnableEvents, ....
    My_Range.Parent.Select 
    ActiveWindow.View = ViewMode 
    ws2.Select 
    With Application 
        .ScreenUpdating = True 
        .EnableEvents = True 
        .Calculation = CalcMode 
    End With 
End Sub 
 
[SIZE=4][/SIZE] 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

Any assistance would be greatly appreciated. Please let me know if I was not clear.

Thanks!!

Greetings ozgrid community,

I've attached the workbook I'm working on complete with a working word cloud / tag cloud generating macro. It uses chandoo's popular method. The two major tweaks I need to make are:

1) Instead of separating out each individual word I would like to just do counts of the number of times each unique cell contents are in the column. I think I will use a pivot table to accomplish this as that's how I do it manually whenever I need to.

This second thing I want to tweak is to adjust font colors based on the frequency (more frequently occurring descriptions set to Red and then work towards green for the lesser common descriptions).This is where I'm hoping I may be able to find some help, as I think I should be able to accomplish task 1 without too much difficulty.

I tried to attach my workbook for everyone's convenience but couldn't get it to upload correctly so my apologies for the lengthy copy and paste. I've commented the code including where I imagine the color tweak would need to be made or added. Although perhaps this will change if I'm including the entire descriptions rather than pulling each unique word from the descriptions?


	VB:
	
 DoAll() 
     
    Dim CloudData As Range 
     
    On Error Resume Next 
     
     'Asks user to specify which column of data they wish to summarize
    Set CloudData = Application.InputBox("Please select a range with the incident information you wish to summarize.", _ 
    "Specify Incident Information", Selection.Address, , , , , 8) 
     
     'If the user selects nothing then a message box reminds the user what they need to / should have done.
    If CloudData Is Nothing Then 
        MsgBox "Please select a column of information to summarize!" 
         
    Else 
         
         'If the user does select a column this message box tells them what they selected.
         'MsgBox "You selected: " & CloudData.Address(External:=True)
         
         'If the user does select a column a new worksheet titled "Frequency Tables" is added.
        Worksheets.Add().Name = "Frequency Tables" 
         
    End If 
     
    Dim rngCell As Range 
    Dim WordsColumn As Collection 
    Dim vntWord As Variant 
     
    On Error Resume Next 
     
    Set WordsColumn = New Collection 
     
     'Splits the contents of each cell to grab unique words and then counts the number of occurances
    For Each rngCell In CloudData.Cells 
        For Each vntWord In Split(Replace(Replace(Replace(rngCell.Value, """", ""), "]", ""), "[", ""), " ") 
            WordsColumn.Add WordsColumn.Count + 1, vntWord 
             
            Sheets("Frequency Tables").Activate 
             
             'Prints new unique words and updates count (number of occurances) on prior unique words
            With Cells(WordsColumn(vntWord), 1) 
                .Value = vntWord 
                .Offset(0, 1) = .Offset(0, 1) + 1 
            End With 
        Next 
    Next 
     
     
     'Sorts frequency table descending. *Only works with currently written code which places
     'words starting in Cell "A1"
     
     
    With Range("A1", Cells(Rows.Count, 2).End(xlUp)).Resize(, 2) 
        .Sort .Cells(1, 2), xlDescending 
         
    End With 
     
     
    Call CreateCloud 
     
     
End Sub 
 
 
Sub CreateCloud() 
     ' this subroutine creates a tag cloud based on the list format tagname, tag importance
     ' the tag importance can have any value, it will be normalized to a value between 8 and 20
     
     
    On Error Goto tackle_this 
     
     
    Range("A1").Select 
    Range(Selection, Selection.End(xlToRight)).Select 
    Range(Selection, Selection.End(xlDown)).Select 
     
     'Selection.Name = "FrequencyTable"
     
     
    Dim size As Integer 
     
     
    size = Selection.Count / 2 
     'size = FrequencyTable.Count / 2
     
     
    Dim tags() As String 
    Dim importance() 
     
     
    Redim tags(1 To size) As String 
    Redim importance(1 To size) 
     
     
    Dim minImp As Integer 
    Dim maxImp As Integer 
     
     
    cntr = 1 
    i = 1 
     
     
    For Each cell In Excel.Selection 
         
         
         'If counter / 2 returns a remainder of 1 i.e. it's a word column then print that "tag"
         '
        If cntr Mod 2 = 1 Then 
            taglist = taglist & cell.Value & ", " 
            tags(i) = cell.Value 
             
             'Otherwise (remainder of 0) it must be a frequency count. Set importance(i) to that
             'frequency count and set max and min importance (frequency) accordingly
        Else 
            importance(i) = Val(cell.Value) 
            If importance(i) > maxImp Then 
                maxImp = importance(i) 
            End If 
            If importance(i) < minImp Then 
                minImp = importance(i) 
            End If 
            i = i + 1 
        End If 
        cntr = cntr + 1 
    Next cell 
     
     
     'Paste values in cell G1
     'Range("G1").Select
     
     
     'Ask user to select which cell they would like to place the tag cloud in
    Set CloudCell = Application.InputBox("Please select the cell where you'd like to place the word cloud.", _ 
    "Specify Word Cloud Destination", Selection.Address, , , , , 8) 
    CloudCell.Select 
     
     
     'Sets active cell value to 'taglist' and cell fonts to size 8.
    ActiveCell.Value = taglist 
    ActiveCell.Font.size = 8 
     
     
     'Starting at first character slot within the cell
    strt = 1 
     
     
     'Starting at tag 1 to however many tags are contained in the frequency table
    For i = 1 To size 
         
         
         'With active cell start changing font size of characters. Applies formatting to
         'the appropriate number of characters based on the length of the word (Len(tags(i)).
         '*To Change Color must somehow adjust the .ColorIndex portion
         
         
        With ActiveCell.Characters(Start:=strt, Length:=Len(tags(i))).Font 
            .size = 6 + Math.Round((importance(i) - minImp) / (maxImp - minImp) * 14, 0) 
            .Strikethrough = False 
            .Superscript = False 
            .Subscript = False 
            .OutlineFont = False 
            .Shadow = False 
            .Underline = xlUnderlineStyleNone 
            .ColorIndex = xlAutomatic 
        End With 
        strt = strt + Len(tags(i)) + 2 
    Next i 
     
     
     
     
     
     
    Exit Sub 
tackle_this: 
     ' errors handled here
    MsgBox "You need to select a table so that I can create a tag cloud", vbCritical + vbOKOnly, "Wow, looks like there is an
error!" 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Thanks a bunch for any help / advice you may provide. And sorry again about the lengthy code paste (I tried but failed to upload). Happy Holidays!


	VB:
	
 special() 
    Dim fil As String 
     
    Set srcwbk = ThisWorkbook 
    Set setoptionsws = srcwbk.Sheets("Main") 
    Set srcws = srcwbk.Sheets("Munzee") 
    Set statsws = srcwbk.Sheets("Stats") 
     
    fil = "" 
    pathfil = "" 
    fileext = "" 
    If setoptionsws.Range("C23").Value = "" Then 
        fil = Application.GetOpenFilename(FileFilter:="Text Files(*.txt),*.txt,Htm Files (*.htm),*.htm,All Files (*.*),*.*") 
        If UCase(fil) = "FALSE" Then 
            End 
             
        Else 
            parsedfil = Split(fil, "") 
            fileext = parsedfil(UBound(parsedfil)) 
            fileext = Right(fileext, InStr(fileext, ".")) 
            For arg = 0 To UBound(parsedfil) - 1 
                pathfil = pathfil + parsedfil(arg) & "" 
            Next arg 
             
            setoptionsws.Range("C23").Value = fil 
        End If 
    Else 
         
        fil = setoptionsws.Range("C23").Value 
    End If 
     
     
    If FileExists(fil) Then 
        tgtb = srcws.Cells.Find("*", srcws.Cells(1), xlFormulas, _ 
        xlWhole, xlByRows, xlPrevious).Row + 1 
        newspecials = 0 
        specialsgone = 0 
        statsrow = 4 
         
         
        nsourcefile = FreeFile 
         'Write the entire file to sText
         
        sfile = fil 
        Open sfile For Input As #nsourcefile 
        sfindtext = Input$(LOF(nsourcefile), 1) 
        Close nsourcefile 
         
        parsedmunzees = Split(sfindtext, "var sites = [") 
        parsedmunzees1 = Split(parsedmunzees(1), "];") 
         
        parsedmunzeelist = Split(parsedmunzees1(0), "['") 
         
         
        For a = 3 To tgtb 
            srcowner = UCase(srcws.Cells(a, 8).Value) 
            srcownernumber = srcws.Cells(a, 9).Value 
            bb = 1 
            Do Until bb > UBound(parsedmunzeelist) 
                munzeeline = Split(parsedmunzeelist(bb), ",") 
                 
                tempsplit = Split(munzeeline(2), "

Hi all,
I had this problem posted on the "devX" forum. Several people tried to help but they think that I am having an "Excel" problem rather than VB6. I thought that I might have better luck here. I will let the people at "devX" know if someone here solves this problem.

Here is the problem:
I have a program that starts with a picture box. In the picture box is a break down diagram of a transmission. Each part has a label with the part number in it. The user should be able to click on a lable and the program then open Excel, find the part, and highlight the row with the proper information. As it stands, the program will do this but only one time. If I close the Excel window and try to click on a part again the Excel window will only flash on the screen for an instant and then right back to the picture box. This is the code that I am using.

This is the "Detect" module.


	VB:
	
Declare Function FindWindow Lib "user32" Alias _ 
"FindWindowA" (ByVal lpClassName As String, _ 
ByVal lpWindowName As Long) As Long 
 
Declare Function SendMessage Lib "user32" Alias _ 
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _ 
ByVal wParam As Long, _ 
ByVal lParam As Long) As Long 
 
Public Sub DetectExcel() 
     ' Procedure dectects a running Excel and registers it.
    Const WM_USER = 1024 
    Dim hWnd As Long 
     ' If Excel is running this API call returns its handle.
    hWnd = FindWindow("XLMAIN", 0) 
    If hWnd = 0 Then ' 0 means Excel not running.
        Exit Sub 
    Else 
         ' Excel is running so use the SendMessage API
         ' function to enter it in the Running Object Table.
        SendMessage hWnd, WM_USER + 18, 0, 0 
    End If 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
This is the main code.


	VB:
	
 Form_Activate() 
    p4l80e.SetFocus 
End Sub 
 
 
Private Sub lbl034_Click() 
     'On Error GoTo erh
     
    Dim MyXL As Object ' Variable to hold reference to Microsoft Excel.
    Dim ExcelWasNotRunning As Boolean ' Flag for final release.
     
     ' Test to see if there is a copy of Microsoft Excel already running.
    On Error Resume Next ' Defer error trapping.
     ' Getobject function called without the first argument returns a
     ' reference to an instance of the application. If the application isn't
     ' running, an error occurs.
    Set MyXL = GetObject(, "Excel.Application") 
    If Err.Number  0 Then ExcelWasNotRunning = True 
    Err.Clear ' Clear Err object in case error occurred.
     
     ' Check for Microsoft Excel. If Microsoft Excel is running,
     ' enter it into the Running Object table.
    DetectExcel 
     
    Set MyXL = GetObject(App.Path & "K and D (152598).xls") 
     
     ' Show Microsoft Excel through its Application property. Then
     ' show the actual window containing the file using the Windows
     ' collection of the MyXL object reference.
    MyXL.Application.Visible = True 
    MyXL.Parent.Windows(1).Visible = True 
     
    Workbooks.Open FileName:="D:K and D (152598).xls" 
    Cells.Find(What:="34034b", After:=ActiveCell, LookIn:=xlFormulas, LookAt _ 
    :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ 
    False, SearchFormat:=False).Activate 
     'Highlights the entire row.
    If IsEmpty(ActiveCell) Then Exit Sub 
    On Error Resume Next 
    If IsEmpty(ActiveCell.Offset(0, -1)) Then Set LeftCell = ActiveCell Else Set LeftCell = ActiveCell.End(xlToLeft) 
    If IsEmpty(ActiveCell.Offset(0, 1)) Then Set RightCell = ActiveCell Else Set RightCell = ActiveCell.End(xlToRight) 
    Range(LeftCell, RightCell).Select 
     
    Exit Sub 
    erh:         MsgBox Error(Err) 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Thanks in advance, Garner

Hi,

After doing some research on the internet and on this forum I have come up with, put together, and modified bits of code that I hope will ultimately do the following:

Create new workbooks with data pertaining to a specific set of data.

For example:
On sheet one I have a range of data...(see attached spreadsheet for visual)
On sheet two I have a list of unique numbers. ID numbers, if you will.

What I am trying to do is cycle through the ID numbers and, lets say the first ID number is 12345...for each row in the master data that has the ID number 12345, I want to select it and copy it to a new workbook. Essentially, create a new range of data (Based on an ID number) and copy all rows that pertain to it to a new workbook. THEN, I need it to cycle to the next ID number on the list in sheet 2, and do the same thing again.

I have two bits of code that SEPARATELY, work.

The first code below goes through my list of numbers and stores them as a variable (I think...). I used the message box portion just as a test to make sure that it was actually working.


	VB:
	
 newTest1() 
    Dim cell As Range 
    Dim keyWord As Variant 
     
    Sheets("Sheet2").Activate 
     
    For Each cell In Range("A1", Cells(Rows.Count, "A").End(xlUp)) 
         
        keyWord = cell.Value 
         
         'MsgBox keyWord
         
    Next cell 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
The following code looks at the master data and searches for an ID number that I specified just as a test. (it worked). Ultimately, I want this ID number to change to the next one on the list of unique numbers after the code has run and do the entire sequence again.


	VB:
	
 Range 
Dim rngG As Range 
For Each c In Intersect(Sheets("Sheet1").UsedRange, Columns("b")) 
     
    If c = "12345" Then 
         
        If rngG Is Nothing Then Set rngG = c.EntireRow 
        Set rngG = Union(rngG, c.EntireRow) 
         
    End If 
Next c 
 
rngG.Select 
Selection.Copy 
Workbooks.Add 
ActiveSheet.Paste 
Range("A1").Select 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
The following is what I get when I put the two together. Logically...I feel like it should work, but it doesn't. Instead, I get the following message. "Run-time error '91': Object variable or With block variable not set" with "rngG.select" being highlighted when I press Debug.


	VB:
	
 newTest3() 
    Dim c As Range 
    Dim rngG As Range 
    Dim cell As Range 
    Dim keyWord As Variant 
     
    For Each cell In Range("A1", Cells(Rows.Count, "A").End(xlUp)) 
        keyWord = cell.Value 
        For Each c In Intersect(Sheets("Sheet1").UsedRange, Columns("b")) 
             
            If c = keyWord Then 
                 
                If rngG Is Nothing Then Set rngG = c.EntireRow 
                Set rngG = Union(rngG, c.EntireRow) 
                 
            End If 
        Next c 
         
        rngG.Select 
         'Selection.Copy
         'Workbooks.Add
         'ActiveSheet.Paste
         'Range("A1").Select
         
    Next cell 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Any suggestions?!?! Any help is extremely appreciated.

i found this thread very helpful on selecting files from a Windows menu and pasting to the active worksheet.
http://www.ozgrid.com/forum/showthread.php?t=90512

however rather than copy a range of cells, i would like to copy the entire range and maintain formatting. i tired expanding the range to a large range (A1:IV10000) yet formats were lost (eg grouped columns and hidden columns). ideally i'd like to replicate the way Excel copies and pastes worksheets when a user clicks on the "select all" button between the row and column headings.

Hi All,

I have a sheet which has a fixed number of rows (conditional formatting applied), number is 150.

The code below allows key users to insert row/rows in between existing data, when required. therefore the sheet length grows.

After insert I want to be able to position cursor on 1st empty row ( code works), then delete entire row, and repeat this automatically for the same number of rows that were inserted.

Any help gratefully recieved.

thanks

isca


	VB:
	
 
Sub InsertNumRows() 
     
     'prevents macro being run in wrong sheet and meesing up data
    If ActiveSheet.Name  Sheet1.Name Then 
        MsgBox "YOU ARE NOT IN THE CURRENT RMAs SHEET" 
        Exit Sub 
    Else 
         
         
         ' SECTION 1 restrict macro users to those with password
        Dim Password As String 
        Password = InputBox("Please enter password below", "Password", "??????") 
         
        If Password  "insert" Then 
            MsgBox "Incorrect Password" 
            Exit Sub 
        Else 
             ' SECTION 2 reminds user to have all other users out of spreadsheet
            Dim Response As Integer 
             
            Response = MsgBox(prompt:="Are All Other Users Out Of Spreadsheet?", Buttons:=vbYesNo) 
            If Response = vbNo Then 
                MsgBox " You Cannot Insert Rows Until All Other Users Out- Click on Tools/Sharedworks to check" 
                Exit Sub 
            Else 
                 ' SECTION 3 reminds user to ensure active cell is in correct row
                Response = MsgBox(prompt:="Is Cursor On Row below Which You Want Rows To be Inserted?", Buttons:=vbYesNo) 
                If Response = vbNo Then 
                    Exit Sub 
                Else 
                     ' SECTION 4 how many rows are required on insert
                    Dim rng, n As Long, k As Long 
                     'Dim rng1 As Range
                    Application.ScreenUpdating = False 
                    rng = InputBox("Enter Number Of Rows Required.") 
                    If rng = "" Then 
                        MsgBox " Incorrect Range Data Entered- Macro will Exit" 
                        Exit Sub 
                    Else 
                         ' SECTION 5 insert rows and copies formula and formats
                        Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(rng, 0)).Select 
                        Selection.EntireRow.Insert 
                         'need To know how many  formulas To copy down.
                         'Assumesfrom A over To last entry In row.
                        k = ActiveCell.Offset(-1, 0).Row 
                        n = Cells(k, 256).End(xlToLeft).Column 
                        Range(Cells(k, 1), Cells(k + Val(rng), n)).FillDown 
                         'next line clears copied data just leaving formulas
                        Selection.Offset(0, 0).EntireRow.SpecialCells(xlConstants).ClearContents 
                         
                         
                    End If 
                End If 
            End If 
        End If 
    End If 
     
     ' SECTION 5 DELETES A BLANK ROW TO KEEP SHEET AT 150 ROWS
     ' SETS CURSOR TO CORRECT INSERT POINT FOR NEW BLANK ROWS
     
    ActiveSheet.Cells(Rows.Count, 1).End(xlUp)(2).Select 
     'Application.Goto Range("A" & ActiveCell.Row), True
    Application.ScreenUpdating = False 
     'MsgBox "LOOK TO SEE WHERE THE CURSOR IS"
     
     'NEED CODE TO MAKE "ENTIREROW.DELETE" REAPEAT AS MANY TIMES AS THE
     ' NUMBER OF ROWS INSERTED IN SECTION 4
     
    ActiveCell.EntireRow.Delete 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


This is my first post so I am going to try to be matter of fact and to the point without waffling yet give as much info as possible. Here goes…

Excel Ver. 2002

I am pretty much the sole user of this Sheet(“Artwork”) and my aim is to automate the population of it. I am keeping track of product instruction manuals I write.

I have designed a functioning userform which transfers the data (limited or complete) into the sheet. Along with the data and at the end of each row it automatically generates 4 checkboxes and links them to 4 offset cells.

This is where I hit a dead end. I am not sure which avenue is suitable or indeed possible. I want to click any checkboxes in the first COLUMN and as a result have it change the complete ROW colorindex of the background. I did achieve this with conditional formatting but it seemed to make the empty sheet bulking when saving and I cannot alter the font size which is another goal on the 3rd column of checkboxes. Am I waffling yet?
The 3rd column checkboxes I want to have the ROW font size drop to 3pt. The 2nd and 4th currently serve no purpose i.e. trigger nothing as a result.

I don’t think I can use the checkbox_click event as the boxes are generated for me so I don’t know which number they will be. The worksheet_change event and calculate event don’t seem to register when the linked cell goes to TRUE or back to FALSE. I tried using FORMS and CONTROLS checkboxes but neither has brought me success.
I was hoping the linkedcell would trigger an event and in turn select and manipulate the entire row in which the linked cell is located….
I’m very quickly going in circle and very slowly going insane.
Thank you for your time.
PS: Due to my limited knowledge the code I have written/adapted to suit my needs may appear a little unorthodox? I hope that in itself is not a problem.
PPS: I have not managed to get the Controls Checkboxes to initalise blank. Currently they appear greyed out with a tick but fully usable? Of minor importance.

I can't attach the file because the blank sheet is 4.5MB?? so here is the main body of code from the userform. If you need anything else I will supply as required, however I can't get anyfiles under the attachment maximum of 48.8kb. My jpeg image was 108kb....


	VB:
	
 
 
Dim aRangeData As Range 
Dim Data As Variant 
 
Public cancel As Boolean 
Private Sub CancelButton_Click() 
    Unload ArtworkRequestForm 
End Sub 
Private Sub OKButton_Click() 
     
    Dim vbWattage As String 
    Dim vbCutCap As String 
    Dim iStandard As String 
     
    iStandard = ComboBox1.Value & " " & Standard.Value 
     
    ActiveWorkbook.Sheets("Artwork").Activate 
    Range("A3").Select 
    Do 
        If IsEmpty(ActiveCell) = False Then 
            ActiveCell.Offset(1, 0).Select 
        End If 
    Loop Until IsEmpty(ActiveCell) = True 
    If ChWickes = True Then ActiveCell.EntireRow.Font.ColorIndex = 1 _ 
Else: ActiveCell.EntireRow.Font.ColorIndex = 41 
     
     
    ActiveCell.Value = StockNo.Value 
    ActiveCell.NumberFormat = "00000" 
    ActiveCell.Offset(0, 1) = StrConv(PartNo, vbUpperCase) 
     '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Wattage.Value = "" Then vbWattage = Wattage.Value _ 
Else vbWattage = Wattage.Value & "W" 
     '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If CutCap.Value = "" Then vbCutCap = CutCap.Value _ 
Else vbCutCap = CutCap.Value & "mm" 
     '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If OptionButton230V = True Then 
        ActiveCell.Offset(0, 2).Value _ 
        = "230V" & " " & LTrim(vbWattage & " " & _ 
        vbCutCap & " " & StrConv(Description.Value, vbProperCase)) 
    ElseIf OptionButton110V = True Then 
        ActiveCell.Offset(0, 2).Value _ 
        = "110V" & " " & LTrim(vbWattage & " " & _ 
        vbCutCap & " " & StrConv(Description.Value, vbProperCase)) 
    ElseIf OptionButtonBothVolt = True Then 
        ActiveCell.Offset(0, 2).Value = _ 
        "110V & 230V" & " " & LTrim(vbWattage & " " & _ 
        vbCutCap & " " & StrConv(Description.Value, vbProperCase)) 
         
    ElseIf OptionButton110V = False _ 
        And OptionButton230V = False _ 
        And OptionButtonBothVolt = False Then 
            ActiveCell.Offset(0, 2).Value = LTrim(vbWattage & " " & _ 
            vbCutCap & " " & StrConv(Description.Value, vbProperCase)) 
             
        End If 
        ActiveCell.Offset(0, 3) = Sku.Value 
        ActiveCell.Offset(0, 4) = iStandard 
        ActiveCell.Offset(0, 5) = Comment.Value 
         
         
        Unload ArtworkRequestForm 
         
        Dim oleObjJob As OLEObject 
        Dim h As Range 
        Set h = ActiveCell.Offset(0, 6) 
        Set oleObjJob = ActiveSheet.OLEObjects.Add(ClassType:= _ 
        "Forms.CheckBox.1", Link:=True, DisplayAsIcon:=False, _ 
        Left:=h.Left + 26, Top:=h.Top + 2, Width:=11, Height:=11) 
         
        With oleObjJob 
            .LinkedCell = ActiveCell.Offset(0, 11).Address 
        End With 
         '=====
        Dim oleObjDoc As OLEObject 
        Set h = ActiveCell.Offset(0, 7) 
        Set oleObjDoc = ActiveSheet.OLEObjects.Add(ClassType:= _ 
        "Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, _ 
        Left:=h.Left + 26, Top:=h.Top + 2, Width:=11, Height:=11) 
         
        With oleObjDoc 
            .LinkedCell = ActiveCell.Offset(0, 12).Address 
        End With 
         '=====
        Dim oleObjComp As OLEObject 
        Set h = ActiveCell.Offset(0, 8) 
        Set oleObjComp = ActiveSheet.OLEObjects.Add(ClassType:= _ 
        "Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, _ 
        Left:=h.Left + 22, Top:=h.Top + 2, Width:=11, Height:=11) 
         
        With oleObjComp 
            .LinkedCell = ActiveCell.Offset(0, 13).Address 
        End With 
         '===== 'Offset(0, 9) is blank so skip'
        Dim oleObjPrtLst As OLEObject 
        Set h = ActiveCell.Offset(0, 10) 
        Set oleObjPrtLst = ActiveSheet.OLEObjects.Add(ClassType:= _ 
        "Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, _ 
        Left:=h.Left + 26, Top:=h.Top + 2.5, Width:=10, Height:=10) 
         
        With oleObjPrtLst 
            .LinkedCell = ActiveCell.Offset(0, 14).Address 
        End With 
         '=
         '==
         '===
         '====
         '=====
         
         'THIS CODE IS A TEST TO INPUT A FORMS AS WELL AS THE CONTROLS CHECKBOXES.
         'FOR THE PURPOSE OF THIS TEST IT IS OFFSET DOWN A ROW JUST TO CLARIFY.
         
        Dim ChBoxComp2 
        Dim hh As Range 
        Dim ii As Range 
        Set hh = ActiveCell.Offset(1, 6) 
        For Each ii In hh.Cells 
            Set ChBoxComp2 = ActiveSheet.CheckBoxes.Add(ii.Left + 23, ii.Top - 1.5 _ 
            , 0.61, 0.85) 
            ChBoxComp2.LinkedCell = ii.Offset(0, 5).Address 
            ChBoxComp2.Text = "" 
        Next 
         
         '=====
         '====
         '===
         '==
         '=
         
    End Sub 
     
    Private Sub StockNo_Change() 
        Dim NumCheck 
        NumCheck = StockNo 
        If Not IsNumeric(NumCheck) Then 
            MsgBox "Please enter a 5 digit Stock No." 
        End If 
        StockNo.MaxLength = 5 
    End Sub 
    Private Sub StockNo_Exit(ByVal cancel As MSForms.ReturnBoolean) 
        If StockNo = vbNullString Then Exit Sub 
        If Len(StockNo) < 5 Then 
            MsgBox "Please enter a 5 digit Stock No." 
            cancel = True 
            Exit Sub 
        End If 
    End Sub 
    Private Sub PartNo_Change() 
        PartNo.MaxLength = 15 
    End Sub 
    Private Sub Description_Change() 
        Description.MaxLength = 20 
    End Sub 
    Private Sub Sku_Change() 
        Dim NumCheck 
        NumCheck = Sku 
        If Not IsNumeric(NumCheck) Then 
            MsgBox "Please enter a 6 digit Stu No." 
        End If 
        Sku.MaxLength = 6 
    End Sub 
    Private Sub Sku_Exit(ByVal cancel As MSForms.ReturnBoolean) 
        If Sku = vbNullString Then Exit Sub 
        If Len(Sku) < 6 Then 
            MsgBox "Please enter a 6 digit Stu No." 
            cancel = True 
            Exit Sub 
        End If 
    End Sub 
    Public Sub ChWickes_Click() 
         'This code activates the Sku box when Wickes is selected
        If ChWickes = True Then 
             
            Sku.Enabled = True 
            Sku.BackColor = &H8000000E 
            Label4.Enabled = True 
             
        ElseIf ChWickes = False Then 
             
            Sku.Enabled = False 
            Sku.BackColor = &H8000000F 
            Label4.Enabled = False 
             
        End If 
    End Sub 
    Private Sub Userform_Initialize() 
        Me.ComboBox1.List = Array( _ 
        "BS", _ 
        "BS ISO", _ 
        "BS EN", _ 
        "BS EN ISO", _ 
        "ISO", _ 
        "prEN", _ 
        "EN", _ 
        "EN ISO") 
    End Sub 
    Private Sub Wattage_Change() 
        Dim NumCheck 
        NumCheck = Wattage 
        If Not IsNumeric(NumCheck) Then 
            MsgBox "Please enter a numeric value." 
        End If 
        Wattage.MaxLength = 4 
    End Sub 
    Private Sub CutCap_Change() 
        Dim NumCheck 
        NumCheck = CutCap 
        If Not IsNumeric(CutCap) Then 
            MsgBox "Please enter a numeric value." 
        End If 
        CutCap.MaxLength = 3 
    End Sub 
     '====================================================================================

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I have two workbooks, a "vehicle workbook" and an "Oil sample" workbook. I'm trying to write a macro that will store the ID of the vehcile in "vehicle workbook" into a varible, open the Oil sample workbook and find instances of the vehicle ID in column B. Next it will copy the entire row, and paste it back into the "vehicle workbook". I've taken some code and modified it to try and make it work but I'm running into problems. I'm very much a newbie to excel and macro's and am learning little by little. This is what I have so far...


	VB:
	
 
Option Explicit 
 
Sub btnFind_Click() 
    Application.ScreenUpdating = False 
    Application.EnableEvents = False 
     
    Dim vehicleNumber As Variant 
    Dim sourceLocation As String 
    Dim sourceFileName As String 
    Dim fileName As String 
    Dim vehicleFileName As String 
     
     
     'referencing the workbook location of the vehicle
    vehicleFileName = ActiveWorkbook.FullName 
    MsgBox (vehicleFileName) 
     
     'copying the vehicle number into memory ie.EFQRTS67WZ100121
    vehicleNumber = ActiveSheet.Range("A13").Value 
     
     
     
     
     'Opens location of OilChart.xls sheet and runs the embedded update macro
    sourceLocation = "C:Documents and SettingsUSERNAMEMy DocumentsReports" 
    sourceFileName = "OilSAMPLE.xls" 
    fileName = (sourceLocation + sourceFileName) 
     
     
     'Open OilChart.xls and activate the Data Sheet
    Workbooks.Open fileName:=fileName 
    Sheets("Data").Activate 
    Application.Run "OilSAMPLE.xls!UpdateData" 'Run the Get Info Macro
     
     
     
     
    Dim R As Range 
    Dim FindAddress As String 
     
     
     
     'Set the range in which we want to search in
    With Worksheets(1).Columns("B") 
         
         'Search for the first occurrence of the item
        Set R = .Find(vehicleNumber) 
         
         'If a match is found then
        If Not R Is Nothing Then 
             
             'Store the address of the cell where the first match is found in a variable
            FindAddress = R.Address 
             
            Do 
                 'select the row with the first match and copy and past it to the vehicle Oil sample page
                R.EntireRow.Select 
                Selection.Copy Destination:=.Workbooks("vehicleFileName").Worksheets("sheet2").Columns("B").End(xlUp).Row + 1

                 
                 'Search for the next cell with a matching value
                Set R = .FindNext(R) 
                 'Search for all the other occurrences of the item i.e.
                 'Loop as long matches are found, and the address of the cell where a match is found,
                 'is different from the address of the cell where the first match is found (FindAddress)
            Loop While Not R Is Nothing And R.Address  FindAddress 
        End If 
    End With 
     
     'Clear memory
    Set R = Nothing 
     
     
    Application.ScreenUpdating = True 
    Application.EnableEvents = True 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Thanks!
Jeff

Good morning and thank you for your help.

I am in search of the magic little code word to advance to the next cycle of a for loop using an If statement. I DO NOT want to exit the entire (exit sub) sub routine nor exit the entire loop and have to re-run the operation. the abridged code is as below:


	VB:
	
 
For DataSet = 1 To LastCellinCol 
     'Check contents of active cell, if null then delete row and subtract one from LastCellinCol
     'Advance to next cycle
    If IsNull(FirstCellinDataSet) Then 
        Selection.EntireRow.Delete Shift:=xlUp 
        LastCellinCol = LastCellinCol - 1 
         
         'incorrect advancement statement...
    Next DataSet 
     
End If 
 'more operations...
Next DataSet 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
The goal of this function is to take a column of data - separated by any given number of spaces - copy each "data set" and transpose paste them into adjacent columns. When empty cells are reached within the column, the entire row is deleted and the loop continues with the next iteration.

Thanks again.


No luck finding an answer? You could always try Google.