I want to search/loop through all the columns headers located on row 1 of the opened file and delete it if it matches dColumns, which is a list of columns I do not needed and I put in a range.
Sub LLextract()
'Last cell in column
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Set WS = ThisWorkbook.Worksheets("Consolidated Data")
With WS
Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
LastCellRowNumber = LastCell.Row + 0
End With
Dim wb As Workbook, wb2 As Workbook
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("CSV Files (*.csv), *.csv", , _
"Select a CSV file", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set selectedworkbook
Set wb2 = ActiveWorkbook
Dim dColumns As Range
Set dColumns = wb.Worksheets("LL Columns to Delete").Range("A:A")
Dim i As Integer
Dim A As Range
For i = 94 To 1 Step -1
Set A = wb2.Cells(1, i)
If wb2.Cells(1, i) = dColumns Then A.EntireColumn.Delete
Next i
'wb2.Worksheets(1).Range("A1").Select
End Sub
You can't do just Range("A"), replace that with Range("A:A").
(But what are you trying to do with dColumns?)
I solved it by just deleting the column when I open wb2. This question is no longer need to be answered or solved.
Related
I have 200 sheets in 1 workbook with an average of 65,000 records on each sheet. I am trying to build a macro that merges all sheets in 1 Excel file into the minimum number of sheets on a NEW Excel file. As Excel has a limitation of 1.xxx million records, the new file would have to have more than 1 sheet, but I am looking to consolidate as much as possible on the new file/tabs.
Below is what I have built so far, but I am struggling to even copy and past the data properly, let alone adding new sheets whenever needed.
Is anyone able to assist?
Sub Combine()
Dim J As Integer
Dim s As Worksheet
Dim wb As Workbook
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Sheets(1).Select
'Opens initial file
strFile = Application.GetOpenFilename
Workbooks.Open strFile
Set INITIALFILE = ActiveWorkbook
' copy headings
Sheets(1).Activate
Range("A1").EntireRow.Select
Selection.Copy
wb.Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A" & Sheets(1).Rows.Count).End(xlUp).Offset(0, 0).PasteSpecial
INITIALFILE.Activate
For Each s In ActiveWorkbook.Sheets
If s.Name <> "Combined" Then
Application.GoTo Sheets(s.Name).[a1]
Selection.CurrentRegion.Select
' Don't copy the headings
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy
wb.Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A" & Sheets(1).Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
INITIALFILE.Activate
End If
Next
End Sub
If you use Range object variables, you rarely need to use Select and your screen will be much the quieter. As noted using a general On Error Resume Next will make it almost impossible to make your code work properly as you will not see useful error messages.
Sub Combine()
Dim NewFile As Workbook
Dim InitialFile As Workbook
Const RowLimit As Long = 1000000
Dim strFile As String
Dim InRows As Long
Dim OutRows As Long
Dim FirstSheet As Worksheet
Dim OutSheet As Worksheet
Dim ASheet As Worksheet
Dim CopySet As Range
Dim OutLoc As Range
Dim Anon As Variant
Set NewFile = ActiveWorkbook
Set FirstSheet = NewFile.Sheets.Add(After:=Sheets(Sheets.Count))
Set OutSheet = FirstSheet
Set OutLoc = OutSheet.Range("A1")
'Opens initial file
strFile = Application.GetOpenFilename
Workbooks.Open strFile
Set InitialFile = ActiveWorkbook
OutSheet.Activate
For Each ASheet In InitialFile.Sheets
Anon = DoEvents()
If ASheet.Name <> "Combined" Then
Set CopySet = ASheet.Cells.SpecialCells(xlCellTypeLastCell)
If CopySet.Row + OutLoc.Row > RowLimit Then
Set OutSheet = NewFile.Sheets.Add(After:=OutSheet)
Set OutLoc = OutSheet.Range("A1")
End If
' Only copy the headings if needed
If OutLoc.Row = 1 Then
Set CopySet = Range(ASheet.Range("A1"), CopySet)
Else
Set CopySet = Range(ASheet.Range("A2"), CopySet)
End If
CopySet.Copy OutLoc
Set OutLoc = OutLoc.Offset(CopySet.Rows.Count, 0)
End If
Next ASheet
FirstSheet.Activate
End Sub
The call to DoEvents() is there to keep the screen current rather than frozen in some half-drawn fashion.
I'm trying to run a macro that I can choose an Excel file where I can filter date and copy (in a specific sheet) and paste the data back to my active workbook (in a specific sheet).
I tried various forums about workbook.open errors but still couldn't get to fix my formula.
Sub CopyFilteredValuesToActiveWorkbook()
Dim wbSource As Workbook, wbDest As Workbook
Dim wsSource As Worksheet, wsDest As Worksheet
Dim rngSource As Range, rngDest As Range
Dim Fname As String
Dim strName As String 'for filter
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a File")
If Fname = "False" Then Exit Sub
Set wbSource = Workbooks.Open(Fname) 'ERROR POINTS THIS LINE
Set wsSource = wbSource.Worksheets("Table 1")
strName = InputBox("Input Year")
wsSource.Range("A:A").AutoFilter Field:=3, Criteria1:="=* & strName & *", Operator:=xlAnd
Set rngSource = wsSource.Range("A:K")
Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets("Sheet3")
Set rngDest = wsDest.Range("A:K")
rngDest.Value = rngSource.Value
wbSource.Close (False) 'Close without saving changes
End Sub
In my first active workbook, column A has a list of numbers, starting in cell A1, and listing down a varied number of rows each time.
I would like to copy all of the column A cells containing information into another workbook (if the second workbook could remain closed during the process that would be preferable).
My desired paste location in the second workbook would be column A in the first empty row available. i.e. I want this second workbook to be a list of all of the data column A of the first workbook has ever had.
Paste this Code into a new Module in the VBA Editor of the Workbook which has the Source Data (Open VBA Editor: ALT+F11) and run the Macro "CopyToAnotherWorkbook".
before running, specify the Destination Workbook Path, hint is in the code.
Sub CopyToAnotherWorkbook()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.ActiveSheet
Dim LastRow_wb%: LastRow_wb = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim arr() As Variant
ReDim arr(0 To LastRow_wb - 1)
For i = 1 To LastRow_wb
arr(i - 1) = ws.Cells(i, 1)
Next i
Dim wb2 As Workbook: Set wb2 = Workbooks.Open("C:\Book2.xlsx") ' <- Paste your Link to the Workbook here!
Dim ws2 As Worksheet: Set ws2 = wb2.Sheets(1)
Dim LastRow_wb2%: LastRow_wb2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
If LastRow_wb2 = 2 Then
LastRow_wb2 = 1
End If
ws2.Range("A" & LastRow_wb2 & ":A" & LastRow_wb2 + UBound(arr)).Value = WorksheetFunction.Transpose(arr)
Application.ScreenUpdating = True
wb2.Close True
Set ws2 = Nothing
Set wb2 = Nothing
Set ws = Nothing
Set wb = Nothing
End Sub
Long time reader and admirer of StackOverflow.
Basically I am trying to to loop through a series of Excel files to copy a range of data and paste it on a single Excel workbook/sheet.
The cell range location (C3:D8, D3:E8) is not always consistent, but the table dimensions are: 29 R x 2 C. Also, the files only have 1 sheet, and aside from the table dimensions specified, no data values in other cells.
In its current form the code is executing, but not pasting anything to its destination Excel file.
I need it to
Find the data dimension in file (table)
Copy the table
Paste to destination (below previous table)
Loop through to next file
Repeat Step 1-4
The code is from:
Excel VBA: automating copying ranges from different workbooks into one final destination sheet?
Thanks a lot for any help, I really appreciate it and please feel tell me to specify anything if my question is vague.
Sub SourcetoDest()
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sDestPath As String
Dim sSourcePath As String
Dim shDest As Worksheet
Dim rDest As Range
Dim vaFiles As Variant
Dim i As Long
'array of folder names under sDestPath
'array of file names under vaFiles
vaFiles = Array("Book1.xls")
sDestPath = "C:\Users"
sSourcePath = "C:\Users"
Set wbDest = Workbooks.Open(sDestPath & "\" & "Book2.xlsm")
Set shDest = wbDest.Sheets(1)
'loop through the files
For i = LBound(vaFiles) To UBound(vaFiles)
'open the source
Set wbSource = Workbooks.Open(sSourcePath & "\" & vaFiles(i))
'find the next cell in col C
Set rDest = shDest.Cells(shDest.Rows.Count, 3).End(xlUp).Offset(1, 0)
'write the values from source into destination
rDest.Resize(5, 1).Value = wbSource.Sheets(1).Range("C7:D33").Value
wbSource.Close False
Next i
End Sub
The below should achieve what you're after.
Option Explicit
Sub copy_rng()
Dim wb As Workbook, wbDest As Workbook, ws As Worksheet, wsDest As Worksheet, wsSrc As Worksheet
Dim wbNames() As Variant
Dim destFirstCell As Range
Dim destColStart As Integer, destRowStart As Long, i As Byte
Dim destPath As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Amend to your sheet name
Set wsSrc = wb.Sheets("Sheet2") ' Amend to sheet name with table data
wbNames = ws.Range("A2:A" & lrow(1, ws)) ' Pass col number into lrow function
destPath = "C:\Users\"
Application.ScreenUpdating = False
For i = 1 To UBound(wbNames, 1)
Set wbDest = Workbooks.Open(destPath & wbNames(i, 1))
Set wsDest = wbDest.Worksheets(1)
With wsDest
Set destFirstCell = .Cells.Find(What:="*")
destColStart = destFirstCell.Column
destRowStart = destFirstCell.Row
.Range(Cells(destRowStart, destColStart), _
Cells(lrow(destColStart, wsDest), icol(destRowStart, wsDest))).Copy
End With
wsSrc.Cells(lrow(1, wsSrc) + 1, 1).PasteSpecial Paste:=xlPasteAll
wbDest.Close False
Next i
Application.ScreenUpdating = True
End Sub
Function lrow(ByVal col_num As Integer, sheet_name As Worksheet) As Long
lrow = sheet_name.Cells(Rows.Count, col_num).End(xlUp).Row
End Function
Function icol(ByVal row_num As Long, sheet_name As Worksheet) As Integer
icol = sheet_name.Cells(row_num, Columns.Count).End(xlToLeft).Column
End Function
Ensure you copy both of the functions across, they're used to create the dimensions of the table, and then copying the table.
You will need to amend the sheet name variables. Let me know if you have any questions.
You need to amend the range of where the workbook names are stored. You need to pass the column number in, so that the last row can be calculated. You can also amend the column in which data is pasted back into the workbook.
With the help of this code you can copy all workbooks and worksheets data
into one workbook
Sub copydata()
Dim fso As Scripting.FileSystemObject
Dim fill As Scripting.File
Dim oldfolder As String
Dim newfolder As String
Dim subfolder As Folder
Dim myfolder As Folder
Dim fd As FileDialog
Dim loopcount As Integer
Dim wb
Dim wb2 As Workbook
Dim rr As Range
Set fso = New Scripting.FileSystemObject
Set wb = ThisWorkbook
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Please Select Folder to copy"
fd.ButtonName = "Go!"
fd.Show
oldfolder = fd.SelectedItems(1)
Set myfolder = fso.GetFolder(oldfolder)
'Application.ScreenUpdating = False
Application.EnableEvents = False
For Each subfolder In myfolder.SubFolders
For Each fill In subfolder.Files
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill,0 , True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A1:Z300").Copy 'Replace your range
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Next subfolder
MsgBox "Done"
For Each fill In myfolder.Files
Application.DisplayAlerts = False
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Or fill Like "*.xlsb" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill, 0, True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A:Z").EntireColumn.Hidden = False
Range("A1:Z1").AutoFilter
Range("A1:Z300").Copy
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Application.EnableEvents = True
End Sub
Daily I receive 3 Excel files via e-mail and I need file data on one workbook.
The layout of each file is different.
File names will have current date added.
File 1 name is : BlankApp_yyyymmdd.xls
File 2 name is : DisRep_yyyymmdd.xls
File 3 name is : PerApp_yyyymmdd.xls
From File 1, I need data from B2, A7, D11, G11 (Single row)
From File 2, I need data from A7, C8, E9, H9 (Single row), A11, C12, E13, H13 (single row), A15, C16, E17, H17 (single row) & A19, C20, E21, H21 (single row)
From File 3, I need data from B2, A7, D11, G11 (single row)
In summary I need six rows of data on my workbook, which should accumulate on a daily basis.
I found code which gives the outcome I require, but this only resolves part of the question i.e. File1 & File3. Still to find a answer for File2.
Sub BlankandPersonalised()
Const CellList As String = "B2,A7,D11,G11"
Const strFldrPath As String = "C:\New folder\" ' point to the folder where the files reside
Dim wsDest As Worksheet
Dim rngDest As Range
Dim rngCell As Range
Dim arrData() As Variant
Dim CurrentFile As String
Dim rIndex As Long, cIndex As Long
Set wsDest = ActiveWorkbook.ActiveSheet
CurrentFile = Dir(strFldrPath & "*.xls*")
Set rngDest = wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1)
ReDim arrData(1 To Rows.Count, 1 To Range(CellList).Cells.Count)
Application.ScreenUpdating = False
Do While Len(CurrentFile) > 0
With Workbooks.Open(strFldrPath & CurrentFile)
rIndex = rIndex + 1
cIndex = 0
For Each rngCell In .Sheets(1).Range(CellList).Cells
cIndex = cIndex + 1
arrData(rIndex, cIndex) = rngCell.Value
Next rngCell
.Close False
End With
CurrentFile = Dir
Loop
Application.ScreenUpdating = True
If rIndex > 0 Then rngDest.Resize(rIndex, UBound(arrData, 2)).Value = arrData
Set wsDest = Nothing
Set rngDest = Nothing
Set rngCell = Nothing
Erase arrData
End Sub
Option Explicit
Sub test()
Dim wb As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet2").Range("C3:D4").Value = wb.Worksheets("Sheet1").Range("A1:B2").Value
End Sub
Using above should be a good start. Not sure where you want the data or what book you want the macro in.
referenced from here
Copy data from another Workbook through VBA
Here is another example of how to pull all the files in one folder into a workbook.
if you just want to copy the entire sheet in one workbook you can use
Sub add_Sheets()
Dim was As Worksheet
Dim wb As Workbook
Set wb = Application.Workbooks.Open("C:\Location of your files") 'Location of where you want the workbook to be
StrFile = Dir("C:\Location\*.xls") 'Dir of where all the xls are.
Do While Len(StrFile) > 0
Debut.Print StrFile
Application.Workbooks.Open ("C:\Location\" & StrFile)
Set ws = ActiveSheet
ws.UsedRange.Select 'Used range of the worksheet
Selection.Copy
wb.Activate
wb.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = StrFile
Range("A1").PasteSpecial Paste:=xlPasteValues
StrFile = Dir
Loop
End Sub