Message box to Fill in StartRow of data to be copied and Row Header in VBA

0

Dear Sirs,

I have copied the folowing module to combine all worksheets in my worbooks and it work perfectly..All sheets have the same format and header (Copied from-https://www.rondebruin.nl/win/s3/win002.htm)

In the existing VBA module 

  • the startRow for data to be copied in each worksheets already define in the VBA (StartRow = 4)

          Is it possible to  input the StartRow using InputBox , after that the VBA will                    continued as usual

  • The row header in first sheets already define as sh.Rows("1:3").

          Is it possible to input row header using InputBox

Sub CopyDataWithoutHeaders()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long
    Dim Input_StartRow As Action

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    ' Delete the summary sheet if it exists.
    Application.DisplayAlerts = False
    On Error Resume Next
    ' ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    ActiveWorkbook.Worksheets("Combined").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    ' Add a new summary worksheet.
    Set DestSh = ActiveWorkbook.Worksheets.Add
    'DestSh.Name = "RDBMergeSheet"
    DestSh.Name = "Combined"

    ' Fill in the start row.
    StartRow = 4

        ' Loop through all worksheets and copy the data to the
    ' summary worksheet.
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
        'Copy header row, change the range if you use more columns
        If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
      '  sh.Range("A1:Z1").Copy DestSh.Range("A1")
        sh.Rows("1:3").Copy DestSh.Rows("1:3")

        End If

            ' Find the last row with data on the summary
            ' and source worksheets.
            Last = LastRow(DestSh)
            shLast = LastRow(sh)

            ' If source worksheet is not empty and if the last
            ' row >= StartRow, copy the range.
            If shLast > 0 And shLast >= StartRow Then
                'Set the range that you want to copy
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

               ' Test to see whether there are enough rows in the summary
               ' worksheet to copy all the data.
                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                   MsgBox "There are not enough rows in the " & _
                   "summary worksheet to place the data."
                   GoTo ExitTheSub
                End If

                ' This statement copies values and formats.
                CopyRng.Copy
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With

            End If

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    ' AutoFit the column width in the summary sheet.
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Function LastRow(sh As Worksheet)

    On Error Resume Next

    LastRow = sh.Cells.Find(What:="*", _

                            After:=sh.Range("A1"), _

                            Lookat:=xlPart, _

                            LookIn:=xlFormulas, _

                            SearchOrder:=xlByRows, _

                            SearchDirection:=xlPrevious, _

                            MatchCase:=False).Row

    On Error GoTo 0

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

Answer
Discuss

Answers

0
Selected Answer

Add the code below at the top of your Sub CopyDataWithoutHeaders().

    Dim StartRow As Long
    Dim InputRow As String
    
    Do
        ' 4 is the default value: change as required
        InputRow = InputBox("Enter the row number to start from", _
                            "Copy data without headers", 4)
        If InputRow = "" Then Exit Sub
        StartRow = Val(InputRow)
    Loop While StartRow < 1
        
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


Note that 'Dim StartRow As Long' already exists as does 'With Application' etc. Your line ' Dim Input_StartRow As Action
' must be replaed with the new code. Remove the following existing lines of code.

   ' Fill in the start row.
    StartRow = 4
Discuss

Discussion

Dear Variattus
Many thanks for the solution to input the StartRow using InputBox. it work perfectly

Still needs the advice for filling in the row header using InputBox from the following

sh.Rows("1:3").Copy DestSh.Rows("1:3")

For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
        'Copy header row, change the range if you use more columns
        If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
      '  sh.Range("A1:Z1").Copy DestSh.Range("A1")
        sh.Rows("1:3").Copy DestSh.Rows("1:3")

        End If
Looking forward to having your further advice in this regards

Best regards
Arsil Hadjar
Arsil (rep: 6) Feb 23, '18 at 5:20 am
This should do the job:-
sh.Rows("1:" & StartRow - 1).Copy DestSh.Rows("1:" & StartRow - 1)
Variatus (rep: 1318) Feb 23, '18 at 5:36 am
Dear Variattus

It works perfectly without using Inputbox to define header rows
Many thanks for the solution.

Best regards
Arsil Hadjar
Arsil (rep: 6) Feb 26, '18 at 4:39 am
Not clear what you mean by "works perfectly without using the input box". I thought that was the solution I provided lol: Will be glad to improve it if needed. However, once you are happy with the solution please remember to accept the answer. Thank you.
Variatus (rep: 1318) Feb 26, '18 at 5:24 am
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login