Need Improvements in my Macro

ie6799u

New Member
Joined
Mar 21, 2017
Messages
17
Hi Team,

I have the below code to copy the multiple workbooks to single workbook.
In this, every time I need to select the range manually. Cause the range might vary from each work book.
Is there anyway to select the range automatically?
For example, in 1st Workbook, the Range is from A2:O23 and 2nd Workbook, the range is from A2:O45 and goes on..
Please help me. Any amendment in the code pls do it.

As per the below code:

I have a sheetname called "List" and mentioning the start and end range.

Code:
Public strFileName As String
Public currentWB As Workbook
Public dataWB As Workbook
Public strCopyRange As String


Sub GetData()
    Dim strWhereToCopy As String, strStartCellColName As String
    Dim strListSheet As String
    
    strListSheet = "List"
    
    On Error GoTo ErrH
    Sheets(strListSheet).Select
    Range("B2").Select
    
    'this is the main loop, we will open the files one by one and copy their data into the masterdata sheet
    Set currentWB = ActiveWorkbook
    GetFileNames
    Do While ActiveCell.Value <> ""
        
        strFileName = ActiveCell.Offset(0, 1) & ActiveCell.Value
        strCopyRange = ActiveCell.Offset(0, 2) & ":" & ActiveCell.Offset(0, 3)
        strWhereToCopy = ActiveCell.Offset(0, 4).Value
        strStartCellColName = Mid(ActiveCell.Offset(0, 5), 2, 1)
        
        Application.Workbooks.Open strFileName, UpdateLinks:=False, ReadOnly:=True
        Set dataWB = ActiveWorkbook
        
        Range(strCopyRange).Select
        sbUnMergeRange
        Selection.Copy
        currentWB.Activate
        Sheets(strWhereToCopy).Select
        lastRow = LastRowInOneColumn(strStartCellColName)
        
        Cells(lastRow + 1, 1).Select
        Selection.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
        Selection.Offset(, 15) = Mid(strFileName, 41, 2)
        Application.CutCopyMode = False
        dataWB.Close False
        Sheets(strListSheet).Select
        ActiveCell.Offset(1, 0).Select
    Loop
    Worksheets(ActiveSheet.Index + 1).Select
    MoveData
    Rows(1).EntireRow.Delete
    Rows(1).EntireRow.Delete
    Rows(1).EntireRow.Delete
    Rows(1).EntireRow.Delete
    sbVBS_To_Delete_Multiple_Columns
    bic
    Exit Sub
    
ErrH:
    MsgBox "It seems some file was missing. The data copy operation is not complete."
    Exit Sub
    
   
    
End Sub


Public Function LastRowInOneColumn(col)
    Dim lastRow As Long
    With ActiveSheet
    lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
    End With
    LastRowInOneColumn = lastRow
End Function


Sub GetFileNames()
    Dim sPath As String
    Dim sFile As String
    Dim iRow As Integer
    Dim iCol As Integer
    Dim splitFile As Variant


    'specify directory to use - must end in "\"
    sPath = "U:\Srikanth\PCM\Charges\Next\"


    iRow = 1
    sFile = Dir(sPath)
    Do While sFile <> ""
        iRow = iRow + 1
        splitFile = Split(sFile, "-")
        For iCol = 0 To UBound(splitFile)
            Sheet1.Cells(iRow, iCol + 2) = splitFile(iCol)
        Next iCol
        sFile = Dir     ' Get next filename
    Loop
End Sub


Sub sbUnMergeRange()
Range("A1:O1000").UnMerge
End Sub
Sub MoveData()
Dim rng As Range
Application.ScreenUpdating = False
On Error Resume Next
Set rng = [J:J].SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
  rng.FormulaR1C1 = "=IF(RC[-1]="""","""",RC[-1])"
  [J:J] = [J:J].Value
End If
rng.Offset(0, -1).ClearContents
End Sub


Sub sbVBS_To_Delete_Multiple_Columns()
Columns("Q:AI").EntireColumn.Delete
End Sub
Sub bic()
    Dim lRow As Long
    Dim SourceRange As Range, DestinationRange As Range, i As Integer
    Dim SourceFullRange1 As String, DestFullRange1 As String
    Dim strListSheet As String
    lRow = Cells(Columns.Count, 16).End(xlUp).Row
    SourceFullRange1 = "P2:P" & lRow
    Set SourceRange = Sheet2.Range(SourceFullRange1)
    DestFullRange1 = "A2:A" & lRow
    Set DestinationRange = Sheet2.Range(DestFullRange1)
    For i = 1 To lRow
    DestinationRange(i, 1).FormulaR1C1 = "=IF(RC[15]=""AT"",""GEBAATWWXXX"",IF(RC[15]=""BG"",""BNPABGSXXXX"",IF(RC[15]=""CZ"",""GEBACZPPXXX"",IF(RC[15]=""DE"",""BNPADEFFXXX"",IF(RC[15]=""DK"",""FTSBDKKKXXX"",IF(RC[15]=""ES"",""BNPAESMMXXX"", IF(RC[15]=""ESF"",""GEBAESMMXXX"",IF(RC[15]=""HU"",""BNPAHUHXXXX"",IF(RC[15]=""IE"",""BNPAIE2DXXX"", IF(RC[15]=""NL"", ""BNPANL2AXXX"", IF(RC[15]=""NO"", ""BNPANOKKXXX"", if(RC[15]=""PL"", ""BNPAPLPXXXX"", IF(RC[15]=""PT"", ""BNPAPTPLXXX"",IF(RC[15]=""RO"", ""FTSBROBUXXX"", ""FTSBSESSXXX""))))))))))))))"
 Next i
End Sub
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

Forum statistics

Threads
1,215,077
Messages
6,122,991
Members
449,094
Latest member
masterms

We've detected that you are using an adblocker.

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

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

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

Disable uBlock

Follow these easy steps to disable uBlock

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