Loop through Range

 

 

 

Find Values Delete Rows

Copy and Paste Code

Loop through Range

 

 

 

Untitled 2

 

 

Home

 


Sub ExtractNumbersFromText()
    Dim Rws As Long, Rng As Range, c As Range
    Dim str As String, Cnt As Integer, Lp As Integer
    Dim st As String, sn As String

    Rws = Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Range(Cells(1, 1), Cells(Rws, 1))

    For Each c In Rng.Cells
        str = c
        sn = ""
        st = ""
        Cnt = Len(c)

        For Lp = 1 To Cnt
            If IsNumeric(Mid(str, Lp, 1)) Or Mid(str, Lp, 1) = "." Then
                sn = sn & Mid(str, Lp, 1)
            Else
                st = st & Mid(str, Lp, 1)
            End If
        Next Lp
        c = st
        If sn <> "" Then c.Offset(0, 1) = sn
    Next c

End Sub

Sub ResetCells()
    Dim Rws As Long, Rng As Range, c As Range
    Rws = Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Range(Cells(1, 1), Cells(Rws, 1))
    For Each c In Rng.Cells
        c = c & c.Offset(0, 1)
    Next c
    Columns("B:B").ClearContents
End Sub


Extract Numbers from Text

Sub OPenMultipleWorkbooks()
'Open Multiple .csv files, this workbooks name is, 'Compare Workbook.xlsm'
    Application.DisplayAlerts = False
    For Each Sheet In Sheets
        If Sheet.Name <> "Compare" Then Sheet.Delete
    Next Sheet
    ChDrive "C:"
    Dim GetFile As Variant, Ws As Worksheet
    Application.ScreenUpdating = False

    GetFile = Application.GetOpenFilename(FileFilter:="CSV (*.CSV), *.CSV", Title:="Open CSV File", MultiSelect:=True)

    On Error Resume Next

    If GetFile <> False Then
        On Error GoTo 0
        For i = 1 To UBound(GetFile)

            Workbooks.Open Filename:=GetFile(i)
            Sheets(1).Move Before:=Workbooks("Compare Workbook.xlsm").Sheets(1)
        Next i

    End If
End Sub


Sub ConCateAll()
    Dim Rws As Long, Rng As Range, c As Range, x As String, cma
    Rws = Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Range(Cells(1, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeConstants, 23)
    x = ""
    For Each c In Rng.Cells
        cma = IIf(c.Row <> Rws, ",", "")
        x = x & c & cma
    Next c
    Range("C1") = x

End Sub

Sub ConCateText()
    Dim Rng As Range, c As Range, x As String, cma, y, t
    Set Rng = Columns("A:A").SpecialCells(xlCellTypeConstants, 2)
    y = Rng.Count
    x = ""
    t = 1
    For Each c In Rng.Cells
        cma = IIf(t <> y, ",", "")
        x = x & c & cma
        t = t + 1
    Next c
    Range("C3") = x

End Sub

Sub ConCateNumbers()
    Dim Rws As Long, Rng As Range, c As Range, x As String, cma, y, t
    Rws = Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Range(Cells(1, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeConstants, 1)
    y = Rng.Count
    x = ""
    t = 1
    For Each c In Rng.Cells
        cma = IIf(t <> y, ",", "")
        x = x & c & cma
        t = t + 1
    Next c
    Range("C5") = x

End Sub



The Codes

We'll use three codes

1-Concatenate All

2-Concatenate Just Text

3-Concatenate Just Numbers

Combine a range of cells into 1 cell

Concatenate Excel VBA

VBA-Examples

Use this code when you want to start a loop, just copy and paste it into your VBA editor and change sheet names and actions as required.




Loop Template


Sub SplyCol()
    Dim rng As Range
    Dim i As Integer
    Dim Orig As Variant
    Dim txt As String
    Set rng = Range("A1")
    Cells.ClearContents
    rng = "the Rain in Spain is wet"
    txt = rng.Value
    Orig = Split(txt, " ")
    For i = 0 To UBound(Orig)
        Cells(1, i + 1) = Orig(i)
    Next i
End Sub


Sub SplyRw()
    Dim rng As Range
    Dim i As Integer
    Dim Orig As Variant
    Dim txt As String
    Set rng = Range("A1")
    Cells.ClearContents
    rng = "the Rain in Spain is wet"
    txt = rng.Value
    Orig = Split(txt, " ")
    For i = 0 To UBound(Orig)
        Cells(i + 1, 1) = Orig(i)
    Next i
End Sub



Split Cell

Loop through Range

 

 

 

Loop Through sheets and Filter



Sub UsingFind()
    Dim ws As Worksheet, sh As Worksheet
    Dim Rws As Long, Rng As Range, c As Range, lookRng As Range

    Set ws = Worksheets("Sheet1")
    Set sh = Worksheets("Sheet2")

    With ws
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range(.Cells(1, 1), .Cells(Rws, 1))
    End With

    Set lookRng = sh.Range("A2")
    Set c = Rng.Find(what:=lookRng, lookat:=xlWhole)

    If Not c Is Nothing Then
        lookRng.Offset(0, 1) = c.Offset(0, 1)
    Else: MsgBox "Not Found"
        Exit Sub
    End If
End Sub


Sub UsingLoop()
    Dim ws As Worksheet, sh As Worksheet
    Dim Rws As Long, Rng As Range, c As Range, lookRng As Range

    Set ws = Worksheets("Sheet1")
    Set sh = Worksheets("Sheet2")

    With ws
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range(.Cells(1, 1), .Cells(Rws, 1))
    End With

    Set lookRng = sh.Range("A4")

    For Each c In Rng.Cells
        If c = lookRng Then lookRng.Offset(0, 1) = c.Offset(0, 1)
    Next c

End Sub



Sub LoopThroughFolder()

    Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
    Dim Rws As Long, Rng As Range
    Set Wb = ThisWorkbook
    'change the address to suite
    MyDir = "C:\WorkBookLoop\"
    MyFile = Dir(MyDir & "*.xls")    'change file extension
    ChDir MyDir
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0

    Do While MyFile <> ""
        Workbooks.Open (MyFile)
        With Worksheets("Sheet1")
            Rws = .Cells(Rows.Count, "A").End(xlUp).Row
            Set Rng = Range(.Cells(2, 1), .Cells(Rws, 2))
            Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            ActiveWorkbook.Close True
        End With
        MyFile = Dir()
    Loop

End Sub

Loop through a Folder of Workbooks

Sum Between Blanks or text, Copy just text, Select non-blank cells

Populate Combox No Duplicates

Home

 

 

 

Loop through Range

 

Loop Through a Range

 

 

Loop through Range

 

 

 

Get a value from in each sheet

Row Differences VBA,,rowdifference macro


Sub SelectDiffRws()
    Dim Rws As Long, Rng As Range, rng2 As Range
    Rws = Cells(Rows.Count, "A").End(xlUp).Row

    Set Rng = Range(Cells(2, 1), Cells(Rws, 2))
    Set rng2 = Rng.RowDifferences(Range("A2"))

    rng2.Select

End Sub

Select Differences Between two columns


Sub FindCellsStartWithA()
    Dim Rws As Long, Rng As Range, c As Range
    Rws = Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Range(Cells(1, 1), Cells(Rws, 1))
    For Each c In Rng.Cells
        If c Like "A*" Then c.Font.Bold = 1
    Next c
End Sub

Loop through a range of cells, bold cells that start with "A"

Find Cells that start with

Multi-Select Files and open

Find Data in other sheet

Edit the code to Your Folder Address and File extensions.

This code will loop through a folder of .XLS workbooks and copy Columns A:B to the workbooks running the code.

excel vba loop through folder


Worksheet Events

Untitled 2

Ways to use special cells

If you used the macro recorder to select special cells you would do this....
Start the recorder
select Column A
hit F5 key on the key board
Click the "Special" button
Click the options for the type of cells you want to select.

This is an example of using special cells with the macro recorder,
it will select non-blank cells in Column A and paste them to cell F1

This is how that same code would look using VBA, same result, cleaner code and cells are not selected.

Select just Non-Blank Cells

Select just Text

Copy and Paste just Numbers

 Copy and past just text

Sum all numbers in column A and place result in B1

Sum each group of numbers in Column A and place in column B

 

XLorate by davesexcel

Private Sub Worksheet_Activate()
    Dim Str As String, D1 As Range

    Set D1 = Range("D1")
    Str = Application.InputBox("Enter a value for D1", "Hello, this is sheet " & Me.Name)

    D1 = Str

    MsgBox "You have entered " & Str & " into cell D1"

End Sub

'**********************************************
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Application.Intersect(Target, Me.Range("A13:B23")) Is Nothing Then
        Cancel = True
        MsgBox "You have Double Clicked on " & Target.Address
    End If

End Sub

'**********************************************
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Not Application.Intersect(Target, Me.Range("C13:d23")) Is Nothing Then
        Cancel = True
        MsgBox "You have Right Clicked on " & Target.Address
    End If
End Sub

'************************************************
Private Sub Worksheet_Calculate()
'Formula in A1 is =E1
'changing E1 will not Be considered a change with the worksheet change event

    MsgBox "Cell A1 Value has changed to " & Range("E1")
End Sub

'********************************************

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub    ' this stops code error if more than one cell is changed at once

    If Not Application.Intersect(Target, Me.Range("A1:C10")) Is Nothing Then    ' indicates the Target range
        MsgBox "You have changed " & Target.Address & " to " & Target
    End If

End Sub

'*************************************
Private Sub Worksheet_Deactivate()
    MsgBox " You have just left " & Me.Name & " ,see ya later"
End Sub
'*******************************************
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Select Case Target.TextToDisplay

    Case "Apples"
        RunApple
    Case "Oranges"
        RunOranges
    Case "Banana"
        RunBanana
    Case "Trees"
        RunTrees
    End Select

End Sub

'****************************************
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)

    MsgBox "Not familiar with Pivot Tables"

End Sub
'******************************************

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Target.Count > 1 Then Exit Sub    ' this stops code error if more than one cell is selected at once
    If Not Application.Intersect(Target, Me.Range("E13:J23")) Is Nothing Then    ' indicates the Target range
        MsgBox "You have selected " & Target.Address & " to " & Target
    End If
    If Target.Column = 13 Then MsgBox "You have selected " & Target.Address & " in Column M"
End Sub