I want to transfer information to a target workbook from a source workbook when the target sheet name is the source sheet name.
I am realtively new to VBA, have been working with it for 2 weeks now and have literally googled my a$$ off. This website has proven to be the best hulp so far.
I have to transpose much information on a standard basis to a different format, where I want to fI want to automate this by the following code:
Sub Transfer()
Dim wbt As Workbook, wbs As Workbook 'wbt = workbook target, wbs = workbooksource
Dim wst As Worksheet, wss As Worksheet 'wbt = worksheet target, wbs = worksheet source
Dim wkt As Integer, wks As Integer, wke As Integer 'wkt = number in target sheet name, wks = number in source sheet name, wke = number in sheet name after which I want to stop transferring information
Dim vFile As Variant
Dim CCT As Range, CCS As Range
Set wbt = ActiveWorkbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
1, "Select One File To Open", , False)
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
Set wbs = ActiveWorkbook
wkt = 1
wks = 1
wke = 16
For Each wks In wbt.wst.("WK " & wkt)
If wks = wkt Then
wbt.wst("WK " & wkt).Range("K13:K63").Value = wbs.wss("WK " & wks).Range("G8:G58").Value
wbt.wst("WK " & wkt).Range("m13:m63").Value = wbs.wss("WK " & wks).Range("h8:h58").Value
wkt = wkt + 1
wks = wks + 1
If wke > wkt Then
wbs.Close (False)
Next
End Sub
This would be better already :
Sub Transfer()
Dim wbt As Workbook, wbs As Workbook 'wbt = workbook target, wbs = workbooksource
Dim wst As Worksheet, wss As Worksheet 'wbt = worksheet target, wbs = worksheet source
Dim wkt As Integer, wks As Integer, wke As Integer 'wkt = number in target sheet name, wks = number in source sheet name, wke = number in sheet name after which I want to stop transferring information
Dim vFile As Variant
Dim CCT As Range, CCS As Range
Set wbt = ActiveWorkbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
1, "Select One File To Open", , False)
If TypeName(vFile) = "Boolean" Then Exit Sub
Set wbs = Workbooks.Open(vFile)
' wkt = 1
' wks = 1
wke = 16
For Each wss In wbs.Sheets
For Each wst In wbt.Sheets
If wst.Name <> wss.Name Or CInt(Replace(wss.Name, "WK ", "")) >= wke Then
Else
wst.Range("K13:K63").Value = wss.Range("G8:G58").Value
'wbt.wst("WK " & wkt).Range("m13:m63").Value = wbs.wss("WK " & wks).Range("h8:h58").Value
' wkt = wkt + 1
' wks = wks + 1
End If
' If wke > wkt Then wbs.Close (False)
Next wst
Next wss
wbs.Close
Set wbs = Nothing
Set wbt = Nothing
End Sub
I don't really get your "wke", it is a number in the sheetname on which you want to limit your copy? If it is, the code might be changed enough already.
Btw, the Set is kind of a way to create quicker references for later use in code but you can't add arguments in there and you have to free them at the end of your code, Set ... = Nothing
Thanks for the reseponses. I have actually found a way to make the code rune fluently. The completed code is:
Option Explicit
Sub Data_Transfer_Ur1_1_1_to_UR1_2()
Dim wbt As Workbook, wbs As Workbook
Dim wst As Worksheet, wss As Worksheet
Dim vFile As Variant
Dim CCT As Range, CCS As Range
Dim array1(1 To 53) As String
Dim og As Integer, bg As Integer
'Set source workbook
Set wbt = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsm", _
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
Dim j As Integer
DataTransferUserForm.Show
og = DataTransferUserForm.InputBoxOG.Value
bg = DataTransferUserForm.InputBoxBG.Value
For j = og To bg
array1(j) = "WK " + CStr(j)
Next j
Set wbs = ActiveWorkbook
Dim i As Integer
For i = 1 To UBound(array1)
wbt.Worksheets(array1(i)).Range("K13:K63").Value = wbs.Worksheets(array1(i)).Range("G8:G58").Value
wbt.Worksheets(array1(i)).Range("m13:m63").Value = wbs.Worksheets(array1(i)).Range("h8:h58").Value
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("J8:J58")
If CCS.Value > 0 Then
CCT.Value = "z"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("K8:K58")
If CCS.Value > 0 Then
CCT.Value = "i"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("L8:L58")
If CCS.Value > 0 Then
CCT.Value = "v"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("m8:m58")
If CCS.Value > 0 Then
CCT.Value = "o"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
Set CCT = wbt.Worksheets(array1(i)).Range("O13")
For Each CCS In wbs.Worksheets(array1(i)).Range("n8:n58")
If CCS.Value > 0 Then
CCT.Value = "bv"
CCT.Offset(0, 1).Value = CCS.Value
End If
Set CCT = CCT.Offset(1, 0)
Next
wbt.Worksheets(array1(i)).Range("q13:q63").Value = wbs.Worksheets(array1(i)).Range("O8:O58").Value
wbt.Worksheets(array1(i)).Range("r13:r63").Value = wbs.Worksheets(array1(i)).Range("P8:P58").Value
Next i
wbs.Close (False)
wbt.Show
Related
I am trying to pull data from a folder containing 300 Workbooks, each named 001, 002 etc.
I am only interested in pulling the data from column G of each file and copying it into a separate folder (each file does not have the same amount if data in row G)
I have been able to copy the data across, but I can't seem to get it to move past column 2 and instead writes over the previous column.
The output needed is:
data from column G workbook"001" pasted into "new sheet" column A
data from column G workbook"002" pasted into "new sheet" column B
and so on
Each file in the folder of 300 only has 1 worksheet each, each labelled: 001,002,...,300
This is the code I already had which results in 2 columns of data where 1 gets replaced by each new sheet instead.
Any help to solve this issue would be greatly appreciated.
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = "C:..."
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
LastRow = Range("G1").CurrentRegion.Rows.Count
Range("G1", Range("G" & LastRow)).Copy ThisWorkbook.Sheets("Sheet1").Range(CurS.Cells(ThisRow, ThisCol + 1), CurS.Cells(ThisRow, ThisCol + CurS.Cells(ThisRow, InfCol).Value))
ActiveWorkbook.Save
ActiveWorkbook.Close
MyFile = Dir
Loop
End Sub
To properly copy in a new column each time, you need a variable that increments during each loop to offset by one each time. When you use ThisCol + 1 you're always getting the same value because ThisCol is not updated.
Something like this:
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = ReplacewithyouFilePath
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
'Let's keep a reference to the workbook
Dim wb As Workbook
Set wb = Workbooks.Open(Filepath & MyFile)
'Let's keep a reference to the first sheet where the data is
Dim ws As Worksheet
Set ws = wb.Sheets(1)
Dim LastRow As Long
LastRow = ws.Range("G1").CurrentRegion.Rows.Count
'We create a variable to increment at each column
Dim Counter As Long
'Let's make the copy operation using the Counter
ws.Range("G1", ws.Range("G" & LastRow)).Copy CurS.Range(CurS.Cells(ThisRow, ThisCol + Counter), CurS.Cells(ThisRow + LastRow - 1, ThisCol + Counter))
'We increment the counter for the next file
Counter = Counter + 1
'We use wb to make sure we are referring to the right workbook
wb.Save
wb.Close
MyFile = Dir
'We free the variables for good measure
Set wb = Nothing
Set ws = Nothing
Loop
End Sub
Import Columns
Sub ImportColumns()
Const FOLDER_PATH As String = "C:\Test"
Const FILE_EXTENSION_PATTERN As String = "*.xls*"
Const SOURCE_WORKSHEET_ID As Variant = 1
Const SOURCE_COLUMN As String = "G"
Const SOURCE_FIRST_ROW As Long = 1
Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_COLUMN_OFFSET As Long = 1
Dim pSep As String: pSep = Application.PathSeparator
Dim FolderPath As String: FolderPath = FOLDER_PATH
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim DirPattern As String: DirPattern = FolderPath & FILE_EXTENSION_PATTERN
Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
If Len(SourceFileName) = 0 Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sfCell As Range
Dim slCell As Range
Do While Len(SourceFileName) > 0
If StrComp(SourceFileName, "Text to column.xlsm", vbTextCompare) _
<> 0 Then ' Why 'Exit Sub'? Is this the destination file?
Set swb = Workbooks.Open(FolderPath & SourceFileName, True, True)
Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
Set sfCell = sws.Cells(SOURCE_FIRST_ROW, SOURCE_COLUMN)
Set slCell = sws.Cells(sws.Rows.Count, SOURCE_COLUMN).End(xlUp)
Set srg = sws.Range(sfCell, slCell)
srg.Copy dfCell
' Or, if you only need values without formulas and formats,
' instead, use the more efficient:
'dfCell.Resize(srg.Rows.Count).Value = srg.Value
Set dfCell = dfCell.Offset(, DESTINATION_COLUMN_OFFSET) ' next col.
swb.Close SaveChanges:=False ' we are just reading, no need to save!
'Else ' it's "Text to column.xlsm"; do nothing
End If
SourceFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Columns imported.", vbInformation
End Sub
I get a
Type Mismatch Error "13"
with the below code. Can anyone assist with where I'm going wrong with my VBA syntax and use of variables.
If Application.WorksheetFuntion.CountIf(Target, r.Value) > 1 Then
I've tried the matchFoundIndex code method to no success...Likely due to incorrect VBA syntax.
The intent of the CountIf line is to look for duplicates in column A. The rest of the code loops through files and worksheets copying the file name, worksheet name, and cell C1 for further analysis. I am a novice at coding and I'm sure there may be Dimmed variables that I'm not using, other formatting, and errors that I have not found yet. Any Help would be appreciative.
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
End If
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
If you want to check for Duplicates in a Range, you can use a Dictionary object.
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
For Each r In Target
If Trim(r.Value) <> "" Then
If Not Dict.exists(r.Value) Then ' not found in dictionary >> add Key
Dict.Add r.Value, r.Value
FindDuplicates = False
Else ' found in Dictionary >> Exit
FindDuplicates = True
Exit For
nd If
End If
Next r
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
I was having a similar experience using CountIF and passing it a range. In my case I was using:
i = Application.WorksheetFunction.CountIf(ws.UsedRange, r.Value)
which was giving me a Type Mismatch error. I had seen other people having success with the first parameter wrapped in Range() so after a few tries I found out that this would work:
i = Application.WorksheetFunction.CountIf(Range(ws.UsedRange.Address), r.Value)
So, I suggest that you change your code to this and see if it works:
If Application.WorksheetFuntion.CountIf(Range(Target.Address), r.Value) > 1 Then
I've written the following code which iterates though my worksheets of my main workbook, checks for a conditional, and then if that conditional is satisfied it copies the active worksheet into a new workbook and saves it. However, I would like to just append the worksheet to the other notebook.
Sub Archive_Sheets()
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Dim SrchRng As Range, cel As Range
Set SrchRng = ws.Range("C9:C108")
Dim bought_amt As Integer
Dim called_amt As Integer
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If InStr(1, cel.Value, "BOUGHT") > 0 Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If InStr(1, cel.Value, "CALLED") > 0 Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
ws.Range("A1").Value = "DONE"
Module8.CopySheet
Exit For
'ws.Delete
End If
Next
End Sub
Sub CopySheet()
Application.DisplayAlerts = False
Dim wb_name_arr() As String
pName = ActiveWorkbook.Path
wbName = ActiveWorkbook.Name ' the file name of the currently active file
shtName = ActiveSheet.Name ' the name of the currently selected worksheet
wb_name_arr() = Split(wbName, ".")
Application.ScreenUpdating = False
ActiveSheet.Select
ActiveSheet.Copy
' NEED TO CHANGE THIS LINE ********************
ActiveSheet.SaveAs Filename:=pName + "\" + wb_name_arr(0) + " archived.xlsx"
'****************************
Application.ScreenUpdating = True
End Sub
The code above will overwrite the new workbook I'm saving to so it's only the most recent sheet. I will already have this workbook created, so if I can append active worksheets to it that would be ideal. I already tried
ActiveSheet.Copy After:=Workbook(pName + "\" + wb_name_arr(0) + " archived.xlsx")
and
ActiveSheet.Copy Before:=Workbooks.Open(pName + "\" + wb_name_arr(0) + " archived.xlsx").Sheets(0)
with no luck.
These line are pseudo-codes. The general idea is Implicit None. Try to explicitly reference to workbooks and sheets instead of activating them. Which is also faster.
Try to avoid using ActiveSheet in your code. Simply try something like this:
Set mySht = ActiveSheet 'This should be set at the beginning of your code
Then whenever you have that Sheet (i.e. ActiveSheet) in your code, use oSht instead.
So, you need to open the Workbook to be able to work on it. Similarly, you can assign a name to different workbooks like this:
Set myWbk = ActiveWorkbook
'Or
Set oWbk = Workbooks("Output.xlsx")
What #A.S.H proposed then works for you like this:
oFile = "Path/to/the/File/" & wb_name_arr(0) & " archived.xlsx"
Set oWbk = Workbooks.Open(oFile)
mySht.Copy Before:=Workbooks(oWbk).sheets(1)
Private Sub that()
Dim aRR As Variant
aRR = ThisWorkbook.Sheets("Sheet1").UsedRange
Dim colC As Long
Dim rowC As Long
colC = ThisWorkbook.Sheets("Sheet1").UsedRange.Columns.Count
rowC = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
ThisWorkbook.Sheets("Sheet2").Range(ThisWorkbook.Sheets("Sheet2").Cells(1, 1), ThisWorkbook.Sheets("Sheet2").Cells(rowC, colC)).Value2 = aRR
End Sub
Try edited code (I've edited both Subs to make them shorter, and also faster as there is no need to use Select and Activate).
Explanation inside the code as comments.
Option Explicit
Sub Archive_Sheets()
Dim SrchRng As Range, cel As Range
Dim bought_amt As Long
Dim called_amt As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
With ws
Set SrchRng = .Range("C9:C108")
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If cel.Value Like "BOUGHT*" Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If cel.Value Like "CALLED*" Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
.Range("A1").Value = "DONE"
CopySheet .Name ' <-- call the function and send the current ws sheet's name
Exit For
End If
End With
Next
End Sub
'==================================================================
Sub CopySheet(wsName As String)
Application.DisplayAlerts = False
Dim wb_name_arr() As String
Dim wb As Workbook
Dim pName As String, wbName As String
pName = ActiveWorkbook.Path
wb_name_arr() = Split(wbName, ".")
Application.ScreenUpdating = False
On Error Resume Next
Set wb = Workbooks(wb_name_arr(0) & " archived.xlsx") ' try to set wb if it's already open
On Error GoTo 0
If wb Is Nothing Then ' <-- wb is Nothing, means it's still close, open it
Set wb = Workbooks.Open(Filename:=pName & "\" & wb_name_arr(0) & " archived.xlsx")
End If
' === Copy the sheet to "archived" file one before tha last sheet ===
Worksheets(wsName).Copy before:=wb.Sheets(wb.Sheets.Count)
Application.ScreenUpdating = True
End Sub
Full code that solves problem.
Sub Archive_Sheets()
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Dim SrchRng As Range, cel As Range
Set SrchRng = ws.Range("C9:C108")
Dim bought_amt As Integer
Dim called_amt As Integer
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If InStr(1, cel.Value, "BOUGHT") > 0 Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If InStr(1, cel.Value, "CALLED") > 0 Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
If called_amt <> 0 Then
ws.Range("A1").Value = "DONE"
Module8.CopySheet
'ws.Delete
End If
End If
Next
End Sub
Sub CopySheet()
Application.DisplayAlerts = False
Dim wb_name_arr() As String
pName = ActiveWorkbook.Path
wbName = ActiveWorkbook.Name ' the file name of the currently active file
shtName = ActiveSheet.Name ' the name of the currently selected worksheet
wb_name_arr() = Split(wbName, ".")
Set mySht = ActiveSheet 'This should be set at the beginning of your code
Set myWbk = ActiveWorkbook
oFile = pName & wb_name_arr(0) & " archived.xlsx"
Set oWbk = Workbooks.Open("path_to_file")
mySht.Copy after:=oWbk.Sheets(oWbk.Sheets.Count)
oWbk.Save
End Sub
Try something like this (to make it simple for the moment, I insert the sheet at beginning):
ActiveSheet.Copy Before:=Workbooks(wb_name_arr(0) & " archived.xlsx").sheets(1)
This works if the destination WB was already open. You may want to open the WB if it is not open yet. Use the following sub to create or open the destination WB:
Sub archiveSheet(ws as Worksheet)
Dim destName As String
destName = left(ThisWorkbook.name, InStrRev(ThisWorkbook.name, ".") - 1) & " archived.xlsx"
Application.DisplayAlerts = False: Application.ScreenUpdating = False
On Error Resume Next
Dim destWB As Workbook: Set destWB = Workbooks(destName)
If destWB Is Nothing Then Set destWB = Workbooks.Open(ThisWorkbook.path + "\" & destName)
If destWB Is Nothing Then
Set destWB = Workbooks.Add
destWB.SaveAs ThisWorkbook.path & "\" & destName
End If
If destWB Is Nothing Then
msgBox "could not open or create " & destName
Else
ws.Copy After:=destWB.Sheets(destWB.Sheets.count)
End If
Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub
Call it from the main routine Archive_Sheets like this:
archiveSheet ws
I am trying to use a file picker, which I have and then get the columns of every file and every sheet within that file into a new sheet. So A1 would have file name,B1 sheet name, C1 and down would have column headers (which are A1:?? in all the files Im picking).
Also some files are large so would having automatic calculation to automatic be helpful?
Also note that I have extra variables in the beggining but not necessarily used.
Here is the code, its a mess:
Sub ColumnHeaders()
'includes filling down
'Skips unreadable files
Dim wb As Workbook, fileNames As Object, errCheck As Boolean
Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
Dim y As Range, intRow As Long, i As Integer
Dim r As Range, lr As Long, myrg As Range, z As Range
Dim boolWritten As Boolean, lngNextRow As Long
Dim intColNode As Integer, intColScenario As Integer
Dim intColNext As Integer, lngStartRow As Long
Dim lngLastNode As Long, lngLastScen As Long
'Skipped worksheet for file names
Dim wksSkipped As Worksheet
Set wksSkipped = ThisWorkbook.Worksheets("Skipped")
' Turn off screen updating and automatic calculation
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Create a new worksheet, if required
On Error Resume Next
Set wksSummary = ActiveWorkbook.Worksheets("Headers")
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
wksSummary.Name = "headers"
End If
' Set the initial output range, and assign column headers
With wksSummary
Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
Set r = y.Offset(0, 1)
Set z = y.Offset(0, -2)
lngStartRow = y.Row
.Range("A1:C1").Value = Array("File Name", "Sheet Name", "headers")
End With
'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary
On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
Set wb = Nothing ' or set a boolean error flag
End If
On Error GoTo 0 ' or your custom error handler
If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)
Else
Debug.Print "Successfully loaded " & fileNames(Key)
wb.Application.Visible = False 'make it not visible
' more working with wb
Code should go in here
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If
Next 'End of the fileNames loop
Set fileNames = Nothing
' Autofit column widths of the report
wksSummary.Range("A1:C1").EntireColumn.AutoFit
' Reset system settings
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.Visible = True
End With
End Sub
I have the picker(a separate function) , I a skipped worksheet incase the file is corrupt, but I obviously am missing the part where to get the headers and sheet names.
Can anyone help?
UPDATE WITH MATTHEW'S CODE~~~~~~~~~~~~~~~~~~~~
Sub ColumnHeaders()
'includes filling down
'Skips unreadable files
Dim wb As Workbook, fileNames As Object, errCheck As Boolean
Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
Dim y As range, intRow As Long, i As Integer
Dim r As range, lr As Long, myrg As range, z As range
Dim boolWritten As Boolean, lngNextRow As Long
Dim intColNode As Integer, intColScenario As Integer
Dim intColNext As Integer, lngStartRow As Long
Dim lngLastNode As Long, lngLastScen As Long
'need addition
Dim wsReport As Excel.Worksheet
Set wsReport = ActiveWorkbook.Sheets("Sheet1") 'Whatever sheet you want to write to
'Skipped worksheet for file names
Dim wksSkipped As Worksheet
Set wksSkipped = ThisWorkbook.Worksheets("Skipped")
' Turn off screen updating and automatic calculation
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Create a new worksheet, if required
On Error Resume Next
Set wksSummary = ActiveWorkbook.Worksheets("Headers")
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
wksSummary.Name = "headers"
End If
' Set the initial output range, and assign column headers
With wksSummary
Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
Set r = y.Offset(0, 1)
Set z = y.Offset(0, -2)
lngStartRow = y.Row
.range("A1:C1").Value = Array("File Name", "Sheet Name", "headers")
End With
'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary
On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
Set wb = Nothing ' or set a boolean error flag
End If
On Error GoTo 0 ' or your custom error handler
If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)
Else
Debug.Print "Successfully loaded " & fileNames(Key)
wb.Application.Visible = False 'make it not visible
' more working with wb
'New addition
Dim iIndex As Integer
Dim lCol As Long
Dim lRow As Long
lRow = 1
'Loop through the worksheets in the current workbook.
For iIndex = 1 To wb.Worksheets.Count
'Set the current worksheet
Set ws = Application.Worksheets(iIndex)
'List out the workbook and worksheet names
wsReport.range("A" & lRow).Value = wb.Name
wsReport.range("B" & lRow).Value = ws.Name
'Start a counter of the columns that we are writing to
lOutputCol = 3
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.Count
'Write the header
wsReport.range(Col_Letter(lOutputCol) & lRow).Value = ws.range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
lCol = lCol + 1
Next lCol
'Increment the row we are writing to
lRow = lRow + 1
Next iIndex
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If
Next 'End of the fileNames loop
Set fileNames = Nothing
' Autofit column widths of the report
wksSummary.range("A1:C1").EntireColumn.AutoFit
' Reset system settings
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.Visible = True
End With
End Sub
TWO FUNCTIONS:
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
and
Function FileDialogDictionary(ByRef file As Object) As Boolean ' returns true if the user cancels
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Dim item As Variant
Dim i As Long
'Create a FileDialog object as a File Picker dialog box.
file.RemoveAll 'clear the dictionary
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path
'of each selected item. Even though the path is a String,
'the variable must be a Variant because For Each...Next
'routines only work with Variants and Objects.
'Use a With...End With block to reference the FileDialog object.
With fd
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
.Title = "Select Excel Workbooks" 'Change this to suit your purpose
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Microsoft Excel files", "*.xlsx,*.xls"
If .Show = -1 Then
'Step through each string in the FileDialogSelectedItems collection.
For Each item In .SelectedItems 'loop through all selected and add to dictionary
i = i + 1
file.Add i, item
Next item
FileDialogDictionary = False
'The user pressed Cancel.
Else
FileDialogDictionary = True
Set fd = Nothing
Exit Function
End If
End With
Set fd = Nothing 'Set the object variable to Nothing.
End Function
When you open a workbook it becomes active so you'll need to create an object that will be the sheet that you are writing to. Somewhere at the top.
Dim wsReport As Excel.Worksheet
Set wsReport = ActiveWorkbook.Sheets("Sheet1") 'Whatever sheet you want to write to
Code to write out the data. Insert where you put "Code should go in here"
Dim iIndex As Integer
Dim lCol As Long
Dim lRow As Long
Dim lOutputCol As Long
lRow = 1
'Loop through the worksheets in the current workbook.
For iIndex = 1 To wb.Worksheets.count
'Set the current worksheet
Set ws = Application.Worksheets(iIndex)
'List out the workbook and worksheet names
wsReport.Range("A" & lRow).Value = wb.name
wsReport.Range("B" & lRow).Value = ws.name
'Start a counter of the columns that we are writing to
lOutputCol = 3
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.count
'Write the header
wsReport.Range(Col_Letter(lOutputCol) & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
Next lCol
'Increment the row we are writing to
lRow = lRow + 1
Next iIndex
And you'll need to add this function
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
I'm trying to figure out a problem in Excel. I am getting an Out of Memory error and I suspect that's not the problem but I don't really know.
Basically, I'm trying to make a macro that searches for a column within 5 tabs in a spreadsheet (the column can be in any of the 5 and it changes a lot) and when it finds it, does a vlookup match to return the column to the appropriate place in the master tab. Here is my code below which seems like it should work but I get the Out of Memory error. the line that is highlighted when I go to debug is the first Vrange = rB line in the if statement.
Dim i As Integer
Dim r As Range
'
Dim wsMaster As Worksheet: Set wsMaster = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("MasterTab")
Dim wsB As Worksheet: Set wsB = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("B")
Dim wsE As Worksheet: Set wsE = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("E")
Dim wsL As Worksheet: Set wsL = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("L")
Dim wsI As Worksheet: Set wsI = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("I")
Dim wsT As Worksheet: Set wsT = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("T")
'
Dim rBHeading As Range: Set rBHeading = wsB.Range("A2:ZA2")
Dim rEHeading As Range: Set rEHeading = wsE.Range("A2:ZA2")
Dim rLHeading As Range: Set rLHeading = wsL.Range("A2:ZA2")
Dim rIHeading As Range: Set rIHeading = wsI.Range("A2:ZA2")
Dim rTHeading As Range: Set rTHeading = wsT.Range("A2:ZA2")
'
Dim rB As Range: Set rB = wsB.Range("A:ZA")
Dim rE As Range: Set rE = wsE.Range("A:ZA")
Dim rL As Range: Set rL = wsL.Range("A:ZA")
Dim rI As Range: Set rI = wsI.Range("A:ZA")
Dim rT As Range: Set rT = wsT.Range("A:ZA")
'
Dim mf_iA_TEXT As String: mf_iA_TEXT = "iA"
'
If Application.CountIf(rBHeading, "iA") = 1 Then
Vrange = rB
Mrange = rBHeading
ElseIf Application.CountIf(rEHeading, "iA") = 1 Then
Vrange = rE
Mrange = rEHeading
ElseIf Application.CountIf(rLHeading, "iA") = 1 Then
Vrange = rL
Mrange = rLHeading
ElseIf Application.CountIf(rIHeading, "iA") = 1 Then
Vrange = rI
Mrange = rIHeading
Else
Vrange = rT
Mrange = rTHeading
End If
'
Dim mf_iA As Variant: mf_iA = Application.Match(mf_iA_TEXT, Mrange, 0)
'
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox lastrow
End With
'
For i = 2 To lastrow
wsMaster.Cells(i, 2) = Application.VLookup(wsMaster.Cells(i, 1), Vrange, mf_iA, 0)
Next i
'
End Sub
I also tried to accomplish this with a case statement but I felt like I got further with the above code. If you could please let me know if this code is dumb, or if I can solve the Out of Memory error, I would greatly appreciate it. If I can get this to work, I will be copying the process with many many more columns, in case that matters. Thanks!!
To get you started, the first 56 lines of code could be written as,
Dim v As Long, vWSs As Variant, Mrange As Range, Vrange As Range, mf_iA as long
Dim wsMaster As Worksheet: Set wsMaster = Workbooks("LBImportMacroTemplate.xlsm").Worksheets("MasterTab")
Dim mf_iA_TEXT As String: mf_iA_TEXT = "iA"
vWSs = Array("B", "E", "L", "I", "T")
With Workbooks("LBImportMacroTemplate.xlsm")
mf_iA = 0: Set Mrange = Nothing: Set Vrange = Nothing
For v = LBound(vWSs) To UBound(vWSs)
If CBool(Application.CountIf(.Sheets(vWSs(v)).Range("A2:ZA2"), mf_iA_TEXT)) Then
Set Mrange = .Sheets(vWSs(v)).Range("A2:ZA2")
Set Vrange = .Sheets(vWSs(v)).Range("A:ZA")
' added the column number assignment on the next line
mf_iA = application.match(mf_iA_TEXT, Mrange, 0)
Exit For
End If
Next v
End With
if mf_iA = 0 then msgbox "Stop here! " & mf_iA_TEXT & "not found!"
'assumed that Mrange and Vrange are not nothing at this point
' and that mf_iA is the numerical column index number for mf_iA_TEXT
'do something with them
Set Mrange = Nothing
Set Vrange = Nothing
Set wsMaster = Nothing
That takes you to the end of the If/ElseIf/End If where you can continue processing. The last three are just reminders to manually set the ranges and workbook object to nothing after you are done with them.