All geek questions in one place

Quoting through worksheets

I am new to VBA (started 3 days ago) trying to build a macro. I hope to get help with my code, as well as to understand what is happening with the code in those parts in which I made a mistake.

The purpose of the code is to collect the values ​​from the cells in the last column of each sheet and compile them in the bank column on the first sheet (which I will create when I open the worksheet for the first time).

My code is very raw and possibly contains a lot of errors. This, for most parts, is copied and pasted from sources (even from a macro recorder). I managed to get it to work, but I hope to condense it. Code that works:

Sub Test()
    Dim LastCol As Long
    Dim rng As Range

    ' Creating a bank sheet
    Sheets.Add

    ' Returning to Page 1
    Sheets("Page 1").Activate

    ' Use all cells on the sheet "Page 1"
    Set rng = Sheets("Page 1").Cells

    ' Find the last column in "Page 1" and COPY
    LastCol = Last(2, rng)
    rng(2, LastCol).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

    ' Paste Selection in Sheet1
    Sheets("Sheet1").Activate
    Sheets("Sheet1").Paste

    ' Reset cursor to next blank space
    Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select

    ' Repeat for Page 2
    Sheets("Page 2").Activate
    Set rng = Sheets("Page 2").Cells
    LastCol = Last(2, rng)
    rng(2, LastCol).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Sheet1").Activate
    Sheets("Sheet1").Paste

    ' Reset cursor to next blank space
    Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select

    ' Repeat for Page 3
    Sheets("Page 3").Activate
    Set rng = Sheets("Page 3").Cells
    LastCol = Last(2, rng)
    rng(2, LastCol).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Sheet1").Activate
    Sheets("Sheet1").Paste

    ' Selecting range to sort
    Set rng = ActiveSheet.Cells
    LastCell = Last(3, rng)
    With rng.Parent
        .Select
        .Range("A1", LastCell).Select
    End With

    ' Sorting
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A177"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:A176")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

. , , -. , :

    For N = 2 To ThisWorkbook.Worksheets.Count

    ' Use all cells on active sheet
    ActiveWorkbook.Worksheets(N).Select
    Set rng = ActiveWorkbook.Cells

    ' Find the last column in active sheet and COPY
    LastCol = Last(2, rng)
    rng(2, LastCol).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

    ' Paste Selection in Sheet1
    Sheets("Sheet1").Activate
    Sheets("Sheet1").Paste

    ' Reset cursor to next blank space
    Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select

    Next N

, .

, ?

, , ( ):

Function Last(choice As Long, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Long

Select Case choice

Case 1:
    On Error Resume Next
    Last = rng.Find(What:="*", _
                    After:=rng.Cells(1), _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
    On Error GoTo 0

Case 2:
    On Error Resume Next
    Last = rng.Find(What:="*", _
                    After:=rng.Cells(1), _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Column
    On Error GoTo 0

Case 3:
    On Error Resume Next
    lrw = rng.Find(What:="*", _
                   After:=rng.Cells(1), _
                   Lookat:=xlPart, _
                   LookIn:=xlFormulas, _
                   SearchOrder:=xlByRows, _
                   SearchDirection:=xlPrevious, _
                   MatchCase:=False).Row
    On Error GoTo 0

    On Error Resume Next
    lcol = rng.Find(What:="*", _
                    After:=rng.Cells(1), _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Column
    On Error GoTo 0

    On Error Resume Next
    Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
    If Err.Number > 0 Then
        Last = rng.Cells(1).Address(False, False)
        Err.Clear
    End If
    On Error GoTo 0

End Select
End Function

Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
On Error GoTo 0
End Function
+4
2

, , . -, , , . "" :

Sub Test()
    Dim LastCol As Long
    Dim LastRow As Long
    Dim NextRowDestination As Long
    Dim rng As Range

    Sheets.Add After:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = "Sheet1"

    With Sheets("Page 1")
        LastCol = Last(2, .Cells)
        LastRow = Last(1, .Cells(1, LastCol).EntireColumn)

        Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol))
        rng.Copy Sheets("Sheet1").Cells(2, 1)
        NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1
    End With

    With Sheets("Page 2")
        LastCol = Last(2, .Cells)
        LastRow = Last(1, .Cells(1, LastCol).EntireColumn)

        Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol))

        rng.Copy Sheets("Sheet1").Cells(NextRowDestination, 1)
        NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1
    End With

    With Sheets("Page 3")
        LastCol = Last(2, .Cells)
        LastRow = Last(1, .Cells(1, LastCol).EntireColumn)

        Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol))

        rng.Copy Sheets("Sheet1").Cells(NextRowDestination, 1)
        NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1
    End With

End Sub

, , . , , ! ( : ", 3 ?" )!

Sub Test2()
    Dim LastCol As Long
    Dim LastRow As Long
    Dim counter As Long
    Dim NextRowDestination As Long

    Dim rng As Range

    Dim ws As Worksheet

    Sheets.Add After:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = "Sheet1"

    NextRowDestination = 2

    For counter = 1 To ActiveWorkbook.Worksheets.Count
        If Left(Worksheets(counter).Name, 4) = "Page" Then

            Set ws = Worksheets(counter)

            With ws
                LastCol = Last(2, .Cells)
                LastRow = Last(1, .Cells(1, LastCol).EntireColumn)

                Set rng = Range(.Cells(2, LastCol), .Cells(LastRow, LastCol))

                rng.Copy Sheets("Sheet1").Cells(NextRowDestination, 1)
                NextRowDestination = Last(1, Sheets("Sheet1").Cells(1, 1).EntireColumn) + 1
            End With
        End If
    Next counter

End Sub

, , , , :  1)  2) , 2.  3) , , .  4) Sheet1 - . .

Test2 , ( ).

0

, :

Option Explicit

Public Sub makeBank()
    Dim bnk As Worksheet, lrBnk As Long, ur As Range, rngBnk As Range
    Dim ws As Worksheet, fr As Long, lr As Long, lc As Long, rngThis As Range

    enableXl False                                      'disable screen and alerts
    With Application.ActiveWorkbook
        For Each ws In .Worksheets                      'go through all sheets
           If ws.Name = "Bank" Then ws.Delete: Exit For 'and remove bnk sheet if exists
        Next
        .Worksheets.Add Before:=.Worksheets(1)          'add new sheet before all others
        Set bnk = .Worksheets(1)                        'set a reference to the new sheet
        bnk.Name = "Bank"                               'rename it

        For Each ws In .Worksheets
            If ws.Name <> "Bank" Then                   'exclude bnk sheet
                fr = ws.UsedRange.Row                   'first used row on current sheet
                lr = ws.UsedRange.Rows.Count            'last used row on current sheet
                lc = ws.UsedRange.Columns.Count         'last used col on current sheet

                Set ur = bnk.UsedRange                  'used range on bnk
                lrBnk = ur.Row + ur.Rows.Count          'last used row on bnk

                Set rngBnk = bnk.Range(bnk.Cells(lrBnk, 1), bnk.Cells(lrBnk + lr - 1, 1))
                Set rngThis = ws.Range(ws.Cells(fr, lc), ws.Cells(lr, lc))

                rngBnk.Value2 = rngThis.Value2          'append this last col to bnk 1st
            End If
        Next
        bnk.Rows(1).EntireRow.Delete                    'delete first (extra) row on bnk
        sortCol bnk.UsedRange.Columns(1)                'sort first column on bnk sheet
    End With
    enableXl True                                       'enable screen and alerts
End Sub

:

Private Sub sortCol(ByVal col As Range)
    With col.Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=col, Order:=xlAscending
        .SetRange col
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
End Sub

Private Sub enableXl(ByVal opt As Boolean)
    With Application
        .ScreenUpdating = opt
        .DisplayAlerts = opt
    End With
End Sub

Sub (makeBank)

  • "" ,
  • ""

  • , "" ,

    • , .
    • "" ( )
    • Bank

  • Bank,

0

Source: https://habr.com/ru/post/1609005/

More articles:


All Articles