Posts by CedricYong

Apologies, this is the full code if needed.

Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If (vbBoolean <> VarType(fnameList)) Then
 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
 
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
 
            Set wbkCurBook = ActiveWorkbook
 
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
 
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
 
               With wbkSrcBook.Sheets
                    Worksheets(1).Select
                    countSheets = countSheets + 1
                    Worksheets(1).Rows(1).EntireRow.Delete
                    Worksheets(1).Range("L:Q, T:X, AC:AC, AF:AV, AX:DI").EntireColumn.Delete
                    Worksheets(1).Cells.EntireColumn.AutoFit
                    Worksheets(1).Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                End With
        For Each wksCurSheet In wbkSrcBook.Sheets
        Next

        For Each wksCurSheet In wbkSrcBook.Sheets
        Worksheets(1).Range("L:Q, T:V, Z:AP, AR:DC").EntireColumn.Delete
        
        Next
        
        For Each wksCurSheet In wbkSrcBook.Sheets

        Worksheets(1).Cells.EntireColumn.AutoFit
        
                Next
                wbkSrcBook.Close SaveChanges:=False
                
            Next
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
 
            MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If
 
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
    
    Dim oWs As Worksheet, TargetWS
    Dim rRng As Range
    Dim iX As Integer
    Dim ws As Worksheet
    Dim c As Range
    
    Sheets(1).Select
    Set TargetWS = Worksheets.Add
    TargetWS.Name = "Combined"
    
    For Each oWs In ThisWorkbook.Worksheets
        Select Case oWs.Name
            Case "Script", "Combined"
                'Do nothing
            Case Else
                iX = iX + 1
                ''/// copy headers first time
                If iX = 1 Then
                    oWs.Range("A1").CurrentRegion.Copy TargetWS.Range("A1")
                Else
                    Set rRng = oWs.Range("A1").CurrentRegion
                    Set rRng = rRng.Offset(1, 0).Resize(rRng.Rows.Count - 1, _
                    rRng.Columns.Count)
                    With TargetWS
                        rRng.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
                    End With
                    End If
            End Select
    Next oWs
    
    Set ws = ActiveSheet
    With ActiveSheet
        Worksheets(1).Select
        Dim last_row As Long
        last_row = .Cells(.Rows.Count, "A").End(xlUp).Row - 1
        MsgBox (last_row), Title:="Number of transactions"
    End With
    
With ActiveSheet
    Worksheets(1).Select
    Dim lastrow As Long
    lastrow = .Cells(.Rows.Count, "L").End(xlUp).Row
    Dim cl As Range
    For Each cl In Range("L2:L" & lastrow)
        cl = "'000" & cl
    Next cl
    Dim myRange As Range
    Set myRange = Range("L2:L" & lastrow)
    myRange.Replace What:="-", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End With
    
With ActiveSheet
        Worksheets(1).Select
        Dim sht As Worksheet
        ThisWorkbook.Worksheets("Combined").Cells.EntireColumn.AutoFit
End With
End Sub

Hi.

For the past hour I have been trouble shooting my VBA code to resolve the following error when trying to merge excel files with the code, however this error pops up every time on the 2nd phase of the code where it copies all sheets' data onto a single sheet named "Combined", can anyone assist to troubleshoot my code?

Sub Combine()
Dim oWs As Worksheet, TargetWS
    Dim rRng As Range
    Dim iX As Integer
    Dim ws As Worksheet
    Dim c As Range
    
    Sheets(1).Select
    Set TargetWS = Worksheets.Add
    TargetWS.Name = "Combined"
    
    For Each oWs In ThisWorkbook.Worksheets
        Select Case oWs.Name
            Case "Script", "Combined"
                'Do nothing
            Case Else
                iX = iX + 1
                ''/// copy headers first time
                If iX = 1 Then
                    oWs.Range("A1").CurrentRegion.Copy TargetWS.Range("A1")
                Else
                    Set rRng = oWs.Range("A1").CurrentRegion
                    Set rRng = rRng.Offset(1, 0).Resize(rRng.Rows.Count - 1, _
                    rRng.Columns.Count)
                    With TargetWS
                        rRng.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
                    End With
                    End If
            End Select
    Next oWs
    
    Set ws = ActiveSheet
    With ActiveSheet
        Worksheets(1).Select
        Dim last_row As Long
        last_row = .Cells(.Rows.Count, "A").End(xlUp).Row - 1
        MsgBox (last_row), Title:="Number of transactions"
    End With
    
With ActiveSheet
    Worksheets(1).Select
    Dim lastrow As Long
    lastrow = .Cells(.Rows.Count, "L").End(xlUp).Row
    Dim cl As Range
    For Each cl In Range("L2:L" & lastrow)
        cl = "'000" & cl
    Next cl
    Dim myRange As Range
    Set myRange = Range("L2:L" & lastrow)
    myRange.Replace What:="-", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End With
    
With ActiveSheet
        Worksheets(1).Select
        Dim sht As Worksheet
        ThisWorkbook.Worksheets("Combined").Cells.EntireColumn.AutoFit
End With
End Sub

I have attached test files just in case it is needed. Thanks!

Hi all,

Once again, it's the newbie Cedric requesting for help.

Well I was figuring out how to automate the process of saving files while adding password, then saving the same file into another folder using file directory.

I was looking and trying to learn over the few days, but can't seem to find a solution.

So hence I am requesting if anyone is willing to give a helping hand.

The requirements and benchmarking file are as attached in the excel file.

Quick Save.test.xlsx

you would need to create blank excel files:

Folder A
File1

File2

File3

Folder B

File4

File5

File6
File7_No PW

Folder C

File8

File9_No PW

Folder "Add PW"

Once again, thanking all for your help/inputs in advance.

Quote from royUK

Try this. Column E seems to have entries for the whole database so I've used that

Ty roy, that worked perfectly for my needs!

Quote from royUK

You can't use CurrentRegion if the data has empty Rows and/or empty columns. Try this

Code

Option Explicit
Sub x()
  Dim oWs As Worksheet
    Dim iX As Integer
    For Each oWs In ThisWorkbook.Worksheets
        With oWs
            Select Case .Name
                Case "Script", "Combined"
                    'Do nothing
                Case Else
                    iX = iX + 1
                    ''/// only copy headers first time
                    If iX = 1 Then
                        .Range(.Cells(7, 1), .Cells(.Rows.Count, 2).End(xlUp)).Copy Sheets("Combined").Range("A1")
                    Else
                        .Range(.Cells(8, 1), .Cells(.Rows.Count, 2).End(xlUp)).Copy Sheets("Combined").Cells(.Rows.Count, 1).End(xlUp).Offset(1)
                    End If
            End Select
        End With
    Next oWs
End Sub

Display More

However Roy, even with your amendments, the script fails to combine all the data onto one. I've attached a file for benchmarking, hope you find it useful as I cannot resolve the issue, and I do appreciate your help greatly!

If everything is working, there should be 326 rows of data.

Thanks in advance!

Quote from CedricYong

Hi Roy, thank you very much for your assistance, I tried inputting your code, however it is running into error :

Run Time error 9 "Subscript out of range"

Any idea what would be causing this?

My full code if it helps

Code

Sub Combine()
    
    Dim oWs As Worksheet, TargetWS
    Dim rRng As Range
    Dim iX As Integer
    Dim ws As Worksheet
    
    For Each oWs In ThisWorkbook.Worksheets
        With oWs
        Select Case .Name
        Case "Script", "Combined"
        'Do nothing
        Case Else
        iX = iX + 1
        ''/// copy headers first time
        If iX = 1 Then
        .Range(.Cells(7, 1), .Cells(.Rows.Count, 2)).Copy Sheets("Combined").Range("A1")
        Else
        .Range(.Cells(8, 1), .Cells(.Rows.Count, 2)).Copy Sheets("Combined").Cells(.Rows.Count, 1).End(xlUp).Offset(1)
        End If
        End Select
        End With
    Next oWs
    
    Set ws = ActiveSheet
    With ActiveSheet
        Worksheets(1).Select
        Dim last_row As Long
        last_row = .Cells(.Rows.Count, "F").End(xlUp).Row - 1
        MsgBox (last_row), Title:="Number of transactions"
    End With
    
    With ActiveSheet
        Worksheets(1).Select
        Dim sht As Worksheet
        ThisWorkbook.Worksheets("Combined").Cells.EntireColumn.AutoFit
    End With
End Sub

Display More

Display More

scratch this qn, as I forgot to add the worksheet "Combined" hence the error.

Quote from royUK

You can't use CurrentRegion if the data has empty Rows and/or empty columns. Try this

Code

Option Explicit
Sub x()
  Dim oWs As Worksheet
    Dim iX As Integer
    For Each oWs In ThisWorkbook.Worksheets
        With oWs
            Select Case .Name
                Case "Script", "Combined"
                    'Do nothing
                Case Else
                    iX = iX + 1
                    ''/// only copy headers first time
                    If iX = 1 Then
                        .Range(.Cells(7, 1), .Cells(.Rows.Count, 2).End(xlUp)).Copy Sheets("Combined").Range("A1")
                    Else
                        .Range(.Cells(8, 1), .Cells(.Rows.Count, 2).End(xlUp)).Copy Sheets("Combined").Cells(.Rows.Count, 1).End(xlUp).Offset(1)
                    End If
            End Select
        End With
    Next oWs
End Sub

Display More

Hi Roy, thank you very much for your assistance, I tried inputting your code, however it is running into error :

Run Time error 9 "Subscript out of range"

Any idea what would be causing this?

My full code if it helps

Sub Combine()
    
    Dim oWs As Worksheet, TargetWS
    Dim rRng As Range
    Dim iX As Integer
    Dim ws As Worksheet
    
    For Each oWs In ThisWorkbook.Worksheets
        With oWs
        Select Case .Name
        Case "Script", "Combined"
        'Do nothing
        Case Else
        iX = iX + 1
        ''/// copy headers first time
        If iX = 1 Then
        .Range(.Cells(7, 1), .Cells(.Rows.Count, 2)).Copy Sheets("Combined").Range("A1")
        Else
        .Range(.Cells(8, 1), .Cells(.Rows.Count, 2)).Copy Sheets("Combined").Cells(.Rows.Count, 1).End(xlUp).Offset(1)
        End If
        End Select
        End With
    Next oWs
    
    Set ws = ActiveSheet
    With ActiveSheet
        Worksheets(1).Select
        Dim last_row As Long
        last_row = .Cells(.Rows.Count, "F").End(xlUp).Row - 1
        MsgBox (last_row), Title:="Number of transactions"
    End With
    
    With ActiveSheet
        Worksheets(1).Select
        Dim sht As Worksheet
        ThisWorkbook.Worksheets("Combined").Cells.EntireColumn.AutoFit
    End With
End Sub

Hi all,

I have some issue with the following code :

    For Each oWs In ThisWorkbook.Worksheets
        Select Case oWs.Name
            Case "Script", "Combined"
                'Do nothing
            Case Else
                iX = iX + 1
                ''/// copy headers first time
                If iX = 1 Then
                    oWs.Range("A7").CurrentRegion.Copy TargetWS.Range("A1")
                Else
                    Set rRng = oWs.Range("A7").CurrentRegion
                    Set rRng = rRng.Offset(1, 0).Resize(rRng.Rows.Count - 1, _
                    rRng.Columns.Count)
                    With TargetWS
                        rRng.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
                    End With
                    End If
            End Select

My worksheets tend to have some blank cells in column A and B, so the current script only pulls data where there are non-empty cells in column A, is there a workaround here as I would want to include the rows that has empty cells in column A as well in my "Combined" Sheet. Please refer to attached for a picture reference. Thanks for reading!

Quote from royUK

Why bot use a Custom NumberFormat?

Well that's another way to do it, but I was hoping to automate the process instead, since most of my process are automated already, hence trying to automate one more step.

Quote from davesexcel

Hello,

Code

    Dim sh As Worksheet
    Dim rng As Range, c As Range

    Set sh = Sheets(1)
    With sh
        Set rng = .Range("L2:L" & .Cells(.Rows.Count, "L").End(xlUp).Row)
        For Each c In rng.Cells
            If c <> "" Then
                With c
                    .NumberFormat = "@"
                    .Value = "000" & c
                End With
            End If
        Next
    End With

Display More

Hi! Thank you very much for your help as well! Tried both codes, and both works perfectly for my needs! Thank you once again

Quote from jolivanes

Depending on the size of your data range, this could be faster because it does not loop.

Code

Sub addvalue_2()
With Sheets("Sheet1").Columns(12).SpecialCells(xlCellTypeConstants, xlNumbers)
.Value = "'000" & .Value
End With
End Sub

Thank you very much for the advise. This code works perfectly!

Hi all,

I need help with my code as I can't seem to add the text value " '000 " at the beginning of each cell that contains value in column L, but i'm running into errors and out of options

What I hope to achieve:

1. Add " '000 " at the beginning of each cell that contains value, but ignoring the header row which is A1

my current code :

Sub addvalue()
With ActiveSheet
    Worksheets(1).Select
    Dim cl As Range
    For Each cl In Range("L")
        cl = "'000" & cl
    Next cl
End With
End Sub

Have solved my first problem, however the code I am about to provide, only works if you do not plan on saving the files that you're importing data from.

Code to import without row 1: Worksheets(1).rows(1).EntireRow.Delete

With wbkSrcBook.Sheets
                    Worksheets(1).Select
                    countSheets = countSheets + 1
                    Worksheets(1).Rows(1).EntireRow.Delete
                    Worksheets(1).Range("L:Q, T:V, Z:AP, AR:DC").EntireColumn.Delete
                    Worksheets(1).Cells.EntireColumn.AutoFit
                    Worksheets(1).Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
End With

Code to disable saving of the files:

wbkSrcBook.Close SaveChanges:=False

Hi all readers! Good morning/aftn/evening.

I really do need some help over here regarding about some functions I've never learned. The following are the current problems I am facing, which I hope I can find the solution here.

All your help is deeply appreciated and thanks in advance!

1.) I am trying to copy data from multiple files onto one sheet (Done), but I want to exclude row "1" while doing so, I don't know the function for that as I am not that experienced yet.

2.) (I'm not sure if this is possible) In column "L", ignoring the header row, which is row 1 after the solution above^, otherwise row 2, I would like to add some values to the column's data in all rows.

For e.g, right now the data is a string of number "1234123412341234" and many other combination of 16 digit numbers, I am trying to add three 0s infront of each cell value, making it

"000xxxxxxxxxxxxxxxx"

x=the cell's number value

This is my current code :

With wbkSrcBook.Sheets
                    Worksheets(1).Select
                    countSheets = countSheets + 1
                    Worksheets(1).Range("L:Q, T:V, Z:AP, AR:DC").EntireColumn.Delete
                    Worksheets(1).Cells.EntireColumn.AutoFit
                    Worksheets(1).Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
End With

Quote from royUK

You still need to use the worksheet

Code

For Each wksCurSheet In ThisWorkBook.Sheets
wksCurSheet.Range("L:Q, T:V, Z:AP, AR:DC").EntireColumn.Delete
Next

Right, forgot about that. Your version is the final correct one. Thanks much!

Quote from royUK

Share your solution in case it helps anyone with a similar problem, also you might still get an improved suggestion. I would think this is the corrected code

Code

For Each wksCurSheet In wbkSrcBook.Sheets
wksCurSheet.Columns("L:Q,T:V,Z:AP,AR:DC").EntireColumn.Delete

Tried that actually, had errors for that one.

The solution was to change from Columns to Range, because I am trying to delete multiple range of columns, hence range.

Next

        For Each wksCurSheet In wbkSrcBook.Sheets
        Range("L:Q, T:V, Z:AP, AR:DC").EntireColumn.Delete

Next

Solved. Thank you

Quote from CedricYong

Hi,

I have a code to delete a set of columns from my data sheet. When the code executes fully, I didn't get the end result I want as none of the columns are deleted, in addition, it always prompts up an error message and when I pressed "debug",

It's this line of code that is causing the issue, and I can't seem to figure out why.

Error message : Run time error "13", Type mismatch

ignore the "Next" as this is supposed to be part of a larger code

Code

        Next

        For Each wksCurSheet In wbkSrcBook.Sheets
        Columns("L:Q,T:V,Z:AP,AR:DC").EntireColumn.Delete


        Next

Display More

Forgot to add in, the 2nd line of the code is meant to select every sheet in the file, which works perfectly normal. So it is the 3rd line that is causing the issue

Hi,

I have a code to delete a set of columns from my data sheet. When the code executes fully, I didn't get the end result I want as none of the columns are deleted, in addition, it always prompts up an error message and when I pressed "debug",

It's this line of code that is causing the issue, and I can't seem to figure out why.

Error message : Run time error "13", Type mismatch

ignore the "Next" as this is supposed to be part of a larger code

        Next

        For Each wksCurSheet In wbkSrcBook.Sheets
        Columns("L:Q,T:V,Z:AP,AR:DC").EntireColumn.Delete


        Next

Quote from royUK

Sorry, it should be/ The cell needs to be within the data

Code

ActiveSheet.Range("A1").CurrentRegion.Rows.Count-1

That worked splendid, thank you very much!