Multiple Excel Files Data extraction issue

Raychin

New Member
Joined
Apr 7, 2022
Messages
25
Office Version
  1. 2013
Platform
  1. Windows
I have a little issue with my code. The purpose is to get a specific range of data from each file (F19:F42), and to copy that range to another file's gathering sheet named "Extraction" piece below the previous piece, and form a column with 720/744 rows of data, depending the month.
The issue is that my code didn't copy and paste every single peace of data range below the previous piece of data, as it should be. Constantly copy the data from the last file; replacing the data in Range("A1") of Sheets("Extraction"), instead of forming a column in A . Can you please help me with that one and give me a correction/adding for my code. Thank you in advance!
Here's the code :

VBA Code:
Sub Extraction()

Dim FileNames As Variant
Dim i As Integer
Application.ScreenUpdating = False
Range("A2").Select
FileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*csv), *.csv", Title:="OpenFile(s)", MultiSelect:=True)

For i = 1 To UBound(FileNames)
    Workbooks.Open FileNames(i)
     'Separate
     
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=";", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1)), TrailingMinusNumbers:=True
        
        
    Range("F19:F42").Select
    Selection.Copy
    Windows("Wind Energy Monthly Forecast.xlsm").Activate
    Sheets("Extraction").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=False
    Workbooks.Open FileNames(i)
    ActiveWorkbook.Close SaveChanges:=False
    ActiveCell.Offset(1, 0).Activate
    
Next i

End Sub
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
See if this works for you:

VBA Code:
Sub Extraction()

Dim FileNames As Variant
Dim i As Integer
Dim wbExtract As Workbook, shtExtract As Worksheet
Dim wbImport As Workbook, shtImport As Worksheet
Dim rngExtract As Range, nxtrowExtract As Long

Application.ScreenUpdating = False
Set wbExtract = ThisWorkbook
Set shtExtract = wbExtract.Worksheets("Extraction")

FileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*csv), *.csv", Title:="OpenFile(s)", MultiSelect:=True)

For i = 1 To UBound(FileNames)
    Set wbImport = Workbooks.Open(FileNames(i))
    Set shtImport = wbImport.ActiveSheet
    
    With shtImport
        .Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
            :=";", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
            1), Array(6, 1)), TrailingMinusNumbers:=True
            
            .Range("F19:F42").Copy
    End With

    With shtExtract
        nxtrowExtract = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        Set rngExtract = .Range("A" & nxtrowExtract)
        rngExtract.PasteSpecial Paste:=xlPasteAll, Transpose:=False
    End With

    wbImport.Close SaveChanges:=False
Next i

wbExtract.Activate
shtExtract.Activate
shtExtract.Range("A1").Select

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Alex - yes! Perfectly!
Thank you! You saved me a lot of manual labor today! :) 🍻
 
Upvote 0
Oops just noticed, somewhere along the line I lost the Period before range, it should be.
Destination:=.Range("A1"),
 
Upvote 0

Forum statistics

Threads
1,223,713
Messages
6,174,043
Members
452,542
Latest member
Bricklin

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