I have a excel sheet "b.xls" in which column A and column B have content like this:
Column A Column B
C1 F1
C2 F2
C3 Z3
I want to copy content at location C1 , C2 , and C3 of sheet "Sheet1" of "b.xls" workbook to location F1 , F2 , Z3 of sheet "Sheet1" of workbook "a.xlsm"
I have wriiten following macro. On runing type mismatch error is displayed at point srcAddress in line of GetData.
Please help
Requirement is copy data without opening b.xls.
Sub Update_Data()
Dim rngA As Range
Dim rngB As Range
Dim srcAddress As Range
Dim destAddress As Range
Dim r As Long 'row iterator
Dim MyPath As String
MyPath = ActiveWorkbook.Path
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
Set rngA = Range("A2", Range("A2").End(xlDown))
Set rngB = rngA.Offset(0, 1)
For r = 1 To rngA.Rows.Count
Set srcAddress = Range(rngA(r).Value)
Set destAddress = Workbooks("a.xlsm").Sheets("Test_data").Range(rngB(r).Value)
GetData MyPath & "b.xls", "Sheet1", srcAddress, destAddress, True, True
'destAddress.Value = srcAddress.Value
Next
End Sub
I just wrote the following code - but then read that b.xls should not be opened, so it might not be what you're after. However, if you're not allowed to open b.xls, how can you access the mapping in b.xls?
anyway, here's the code, maybe you can use parts of it. It prevents screen updating, so the user will not see that another file is opened:
Sub UpdateData()
Dim rngSource As Range
Dim wbTarget As Workbook
Dim wsTarget As Worksheet
Application.ScreenUpdating = False 'This will prevent the workbook to be displayed during execution
On Error Resume Next
Set wbTarget = Workbooks("a.xls")
If Err.Number Then
Err.Clear
Set wbTarget = Workbooks.Open(YourPath & "a.xls")
End If
Set wsTarget = wbTarget.Worksheets("Sheet1")
With Worksheets("Sheet1")
For Each rngSource In .Range("A1").Resize(.Range("A" & .Rows.Count).End(xlUp).Row)
wsTarget.Range(rngSource.Offset(, 1).Value) = .Range(rngSource.Value).Value
Next
End With
wbTarget.Save
wbTarget.Close
Application.ScreenUpdating = True
End Sub
Related
This question is vaguely similar to renaming multiple worksheets from list using VBA, but is too different to get the answer from that question.
I will regularly need to rename dozens of worksheets in various incoming workbooks.
I wish to rename all worksheets by first copying all the worksheet names into a secondWorkbook.sheets(1) colA, manually creating new names in ColB, and then run a second macro to update the names in the originalWorkbook.
I am stuck on the second macro, but will provide both macros below. If anyone has a shorter/better way of writing these macros, I am all eyes.
First macro - copy all worksheet names into a new workbook.sheet(1).colA. This works, and creates a new unsaved workbook with the tab names in ColA
Sub GrabAllTabNamesIntoTempWorkbookColA()
Dim tst, tmp, allTabNames As String
Dim i, cnt, cnt2 As Long
Dim wb, wbTmp As Workbook, xWs, ws1 As Worksheet
Dim arrOldNames, arrNewNames As Variant
ReDim arrOldNames(999)
cnt = 0
With ActiveWorkbook
For Each xWs In .Worksheets
If xWs.Visible = xlSheetVisible Then
arrOldNames(cnt) = xWs.Name
cnt = cnt + 1
End If
Next
End With
ReDim Preserve arrOldNames(cnt - 1)
cnt2 = 1
Set wbTmp = Workbooks.Add
Set ws1 = wbTmp.Sheets(1)
For i = 1 To cnt
ws1.Range("A" & i).Value = arrOldNames(i - 1)
Next
MsgBox "Done. Copied " & cnt & " tab names."
End Sub
Here is the macro I am stuck on. Both workbooks are open on screen, and I don't mind editing the macro to provide the workbook names. Unsure how to reference an unsaved workbook with a name like "Book4 - Microsoft Excel", so I have been saving it as Temp.xlsx and referencing it as namesWb. The workbook with the tabs to be renamed is referenced as targetWb
Sub RenameAllTabsFromColAInTempWorkbook()
Dim namesWb, targetWb As Workbook
Dim colA, colB As Variant
Set namesWb = Windows("Temp.xlsx")
Set targetWb = ActiveWorkbook
ReDim colA(999), colB(999)
cnt = 0
With namesWb
Sheets(1).Activate
For i = 1 To 999
If Range("A" & i).Value = "" Then Exit For
colA(i - 1) = Range("A" & i).Value
colB(i - 1) = Range("B" & i).Value
cnt = cnt + 1
Next
ReDim Preserve colA(cnt)
ReDim Preserve colB(cnt)
End With
For each oldname in colA()
'Stuck here...
Next
End Sub
I realize that I could again loop through the targetWb and, for each tabname, find the location of that tabname in ColA() and rename it with the same position name from tabB() - but I am wondering if there is a faster/better way to do this.
You can loop through active workbooks like this:
Sub t()
Dim mainWB As Workbook, tempWB As Workbook
Dim wb As Workbook
Set mainWB = ActiveWorkbook
For Each wb In Application.Workbooks
'Loops through the workbooks.
Debug.Print wb.Name
If wb.Name Like "Book*" Then
Set tempWB = wb
End If
Next wb
End Sub
Edit: Since you only have two open workbooks, you can shorten that:
Sub t()
Dim mainWB As Workbook, tempWB As Workbook
Dim wb As Workbook
Set mainWB = ActiveWorkbook ' MAKE SURE THIS IS CORRECT!! May need `ThisWorkbook` if the new temporary one becomes the active one.
For Each wb In Application.Workbooks
'Loops through the workbooks.
Debug.Print wb.Name
If wb.Name <> mainWB.Name And wb.Name <> "PERSONAL.XLSB" Then
Set tempWB = wb
' Now do whatever you need with the Temporary workbook.
End If
Next wb
End Sub
I've refactored both your Sub's to show a more robust method.
Dim all variables, with explicit types (some of yours were defaulting to Variant)
Record the Workbook being processed in the top of the Names list
Still processes the ActiveWorkbook
Save the Temp workbook into the same folder as ActiveWorkbook
Rename... now skips any missing new names
Detect missing OldNames (see comment in code, place any response you want there)
Detect failed Renames (eg could be invalid characters in the new names)
Sub GrabAllTabNamesIntoTempWorkbookColA()
Dim wbToRename As Workbook
Dim wbTmp As Workbook
Dim xWs As Worksheet
Dim ws1 As Worksheet
Dim arrOldNames As Variant
Dim arrNewNames As Variant
Dim cnt As Long
Set wbToRename = ActiveWorkbook
With wbToRename
' Size array based on number of sheets in workbook
ReDim arrOldNames(1 To .Worksheets.Count, 1 To 1)
cnt = 0
For Each xWs In .Worksheets
If xWs.Visible = xlSheetVisible Then
cnt = cnt + 1
arrOldNames(cnt, 1) = xWs.Name
End If
Next
End With
Set wbTmp = Workbooks.Add
Set ws1 = wbTmp.Sheets(1)
'Place data in sheet in one go
ws1.Cells(1, 1) = wbToRename.Name
ws1.Cells(2, 1).Resize(UBound(arrOldNames, 1), 1) = arrOldNames
MsgBox "Done. Copied " & cnt & " tab names."
'Save workbook
wbTmp.SaveAs Filename:=wbToRename.Path & "\Temp", FileFormat:=xlOpenXMLWorkbook
End Sub
Sub RenameAllTabsFromColAInTempWorkbook()
Dim namesWb As Workbook
Dim targetWb As Workbook
Dim wsNames As Worksheet
Dim ws As Worksheet
Dim NamesList As Variant
Dim cnt As Long
Dim i As Long
Set namesWb = Application.Workbooks("Temp.xlsx")
Set targetWb = Application.Workbooks(namesWb.Worksheets(1).Cells(1, 1).Value)
cnt = 0
Set wsNames = namesWb.Worksheets(1)
With wsNames
'Get Names into one variable, based on actual number of rows
NamesList = wsNames.Range(wsNames.Cells(2, 2), wsNames.Cells(wsNames.Rows.Count, 1).End(xlUp)).Value
For i = 1 To UBound(NamesList, 1)
' Check if the Name has been entered
If NamesList(i, 2) <> vbNullString Then
'Get reference to sheet by old name, and handle if sheet is missing
Set ws = Nothing
On Error Resume Next
Set ws = targetWb.Worksheets(NamesList(i, 1))
On Error GoTo 0
' Rename sheet
If Not ws Is Nothing Then
On Error Resume Next
ws.Name = NamesList(i, 2)
On Error GoTo 0
If ws.Name <> NamesList(i, 2) Then
' Rename failed! What now?
End If
Else
'Sheet Missing! What now?
End If
End If
Next
End With
End Sub
I have the following macro to loop through directory and put data in my master file. The masterfolder contains all information about employee hours spend on a specific project. However, the sheet name of the employee hour files (non-master files) might differ. I managed to change this for the activesheet (master sheet) but I'm not sure how to adjust this for the non-active (non-master) sheets (in formula this specific sentence: Set CurrentWBSht = CurrentWB.Sheets("Sheet1")
Option Explicit
Sub CopyToMasterFile()
Dim MasterWB As Workbook
Dim MasterSht As Worksheet
Dim MasterWBShtLstRw As Long
Dim FolderPath As String
Dim TempFile
Dim CurrentWB As Workbook
Dim CurrentWBSht As Worksheet
Dim CurrentShtLstRw As Long
Dim CurrentShtRowRef As Long
Dim CopyRange As Range
Dim ProjectNumber As String
Dim wbname As String
Dim sheetname As String
wbname = ActiveWorkbook.Name
sheetname = ActiveSheet.Name
FolderPath = "C:\test file\"
TempFile = Dir(FolderPath)
Dim WkBk As Workbook
Dim WkBkIsOpen As Boolean
'Check is master is open already
For Each WkBk In Workbooks
If WkBk.Name = wbname Then WkBkIsOpen = True
Next WkBk
If WkBkIsOpen Then
Set MasterWB = Workbooks(wbname)
Set MasterSht = MasterWB.Sheets(sheetname)
Else
Set MasterWB = Workbooks.Open(FolderPath & wbname)
Set MasterSht = MasterWB.Sheets(sheetname)
End If
ProjectNumber = MasterSht.Cells(1, 1).Value
Do While Len(TempFile) > 0
'Checking that the file is not the master and that it is a xlsx
If Not TempFile = wbname And InStr(1, TempFile, "xlsx", vbTextCompare) Then
Set CopyRange = Nothing
'Note this is the last used Row, next empty row will be this plus 1
With MasterSht
MasterWBShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set CurrentWB = Workbooks.Open(FolderPath & TempFile)
Set CurrentWBSht = CurrentWB.Sheets("Sheet1")
With CurrentWBSht
CurrentShtLstRw = .Cells(.Rows.Count, "AE").End(xlUp).Row
End With
For CurrentShtRowRef = 1 To CurrentShtLstRw
If CurrentWBSht.Cells(CurrentShtRowRef, "AE").Value = ProjectNumber Then
'This is set to copy from Column A to Column L as per the question
If CopyRange Is Nothing Then
'If there is nothing in Copy range then union wont work
'so first row of the work sheet needs to set the initial copyrange
Set CopyRange = CurrentWBSht.Range("AE" & CurrentShtRowRef & _
":AQ" & CurrentShtRowRef)
Else
'Union is quicker to be able to copy from the sheet once
Set CopyRange = Union(CopyRange, _
CurrentWBSht.Range("AE" & CurrentShtRowRef & _
":AQ" & CurrentShtRowRef))
End If ' ending If CopyRange Is Nothing ....
End If ' ending If CurrentWBSht.Cells....
Next CurrentShtRowRef
CopyRange.Select
'add 1 to the master file last row to be the next open row
CopyRange.Copy
MasterSht.Cells(MasterWBShtLstRw + 1, 1).PasteSpecial xlPasteValues
CurrentWB.Close savechanges:=False
End If 'ending If Not TempFile = "master.xlsx" And ....
TempFile = Dir
Loop
ActiveSheet.Range("A1:M200").RemoveDuplicates Columns:=Array(1, 2, 4, 8, 9, 10, 11, 12), Header:=xlYes
End Sub
There are a few ways to refer to a worksheet, without knowing their names in advance:
'To get a specific worksheet:
Set CurrentWBSht = CurrentWB.Worksheets(10)
'To get the last worksheet:
Set CurrentWBSht = CurrentWB.Worksheets(Worksheets.Count)
'To get the pre last worksheet:
Set CurrentWBSht = CurrentWB.Worksheets(Worksheets.Count-1)
If the workbook only has 1 sheet then you can simply do this:
Set CurrentWBSht = CurrentWB.Sheets(1)
If there are more than 1 sheet in the 'non-master' workbook, you could have this:
Set CurrentWB = Workbooks.Open(FolderPath & TempFile)
Dim oWS As Worksheet
' Loop through all sheets to find the sheet we want
For Each oWS In CurrentWB.Worksheets
If oWS.Name = sheetname Then
Set CurrentWBSht = oWS
Exit For
End If
Next
You could add a flag in the loop above to confirm if you found a sheet
Also, from what I can see, your macro is in your master sheet?. If that's the case, you don't need to do the check if the 'Master workbook' is open. You can just use ThisWorkbook.Worksheets(1).Name (ThisWorkbook is the object for the workbook where your macro is running from)
I've been trying to come up with a way to split a workbook into separate workbooks based on identified worksheets in the workbook.
For example:
Say I had a worksheet for every letter in the alphabet.
I would want to split worksheets A through C into a new workbook named "A through C."
D through I will go into a new workbook named "D through I."
etc...
My idea would be to first insert a worksheet that in column A names the new workbook it will become and Columns b through as many columns as there are will the names of the worksheets to be copied into the new workbook.
Does anyone have an idea of how to make a macro for this? I've tried myself but have been unsuccessful.
Thank you!
I found this Macro out there. Does anyone think it can be modified to work?
Sub Test()
Dim Sh As Worksheet
Dim Rng As Range
Dim c As Range
Dim List As New Collection
Dim Item As Variant
Dim WB As Workbook
Application.ScreenUpdating = False
Set Sh = Worksheets("Sheet1")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
On Error Resume Next
For Each c In Rng
List.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Rng = Sh.Range("A1:H" & Sh.Range("A65536").End(xlUp).Row)
For Each Item In List
Set WB = Workbooks.Add
Rng.AutoFilter Field:=1, Criteria1:=Item
Rng.SpecialCells(xlCellTypeVisible).Copy WB.Worksheets(1).Range("A1")
Rng.AutoFilter
With WB
.SaveAs ThisWorkbook.Path & "\" & Item & ".xls"
.Close
End With
Next Item
Sh.Activate
Application.ScreenUpdating = True
End Sub
The following code assumes you have your control sheet (named "Split Parameters") in the workbook containing the macro, and it is set out with the desired filenames in column A, and the sheets that you wish to copy into that file (from the ActiveWorkbook, which might, or might not, be the one containing the macro) listed in columns B, C, etc. Row 1 is assumed to be headings, and is therefore ignored.
Sub SplitBook()
Dim lastRow As Long
Dim LastColumn As Long
Dim srcWB As Workbook
Dim newWB As Workbook
Dim i As Long
Dim c As Long
Dim XPath As String
Dim newName As String
Dim sheetName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set srcWB = ActiveWorkbook
XPath = srcWB.Path
With ThisWorkbook.Worksheets("Split Parameters")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow
'Take the first worksheet and create a new workbook
sheetName = .Cells(i, "B").Value
srcWB.Sheets(sheetName).Copy
Set newWB = ActiveWorkbook
'Now process all the other sheets that need to go into this workbook
LastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
For c = 3 To LastColumn
sheetName = .Cells(i, c).Value
srcWB.Sheets(sheetname).Copy After:=newWB.Sheets(newWb.Sheets.Count)
Next
'Save the new workbook
newName = .Cells(i, "A").Value
newWB.SaveAs Filename:=xPath & "\" & newName & ".xls", FileFormat:=xlExcel8
newWB.Close False
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I am attempting to write a macro in a workbook whose purpose is to display the key information from each of a set of excel files. the first column contains the name of the file which will be used in the code.
the code I have written so far should loop through the list of 11 file names in the summary sheet and pull the info called from cell E21 in each of those files and place it in cell Hx in the summary sheet.
I have had no luck getting it to work so far, my first error im getting is "invalid Qualifier" on the line that says "MySheet". I know that there are alot of other mistakes here as I have never attempted to write a sub that pulls from other closed workbooks.
My code is as follows:
Option Explicit
Sub OEEsummmary()
Dim Gcell As Range
Dim Txt$, MyPath$, MyWB$, MySheet$
Dim myValue As Integer
Dim x As Long
Dim v As Variant, r As Range, rWhere As Range
MyPath = "L:\Manufacturing Engineering\Samuel Hatcher\"
x = 2
MySheet = ActiveSheet.Name
Application.ScreenUpdating = False
Do While MySheet.Range("A" & x).Value <> ""
MyWB = MySheet.Range("A" & x).Txt
Workbooks.Open Filename:=MyPath & MyWB
Set Gcell = ActiveSheet.Range("E21")
With ThisWorkbook.ActiveSheet.Range("A" & x)
.Value = "Item"
.Offset(7, 0).Value = Gcell.Value
End With
ActiveWorkbook.Close savechanges:=False
x = x + 1
Loop
End Sub
Ive looked at what an invalid qualifier error is and i dont understand what i have wrong with that part of my code. Any help with this and any other blinding errors would be greatly appreciated!
The issue I see that's causing the Invalid Qualifier error is that you are declaring MySheet as a string, but trying to use it as a Worksheet object. Below I've declared it as a worksheet and set it to the Activesheet. I also changed the ThisWorkbook.ActiveSheet reference to MySheet, which I think is what you want. Also changed Txt to Text:
Sub OEEsummmary()
Dim Gcell As Range
Dim MySheet As Worksheet
Dim Txt$, MyPath$, MyWB$
Dim myValue As Integer
Dim x As Long
Dim v As Variant, r As Range, rWhere As Range
MyPath = "L:\Manufacturing Engineering\Samuel Hatcher\"
x = 2
Set MySheet = ActiveSheet
Application.ScreenUpdating = False
Do While MySheet.Range("A" & x).Value <> ""
MyWB = MySheet.Range("A" & x).Text
Workbooks.Open Filename:=MyPath & MyWB
Set Gcell = ActiveSheet.Range("E21")
With MySheet.Range("A" & x)
.Value = "Item"
.Offset(7, 0).Value = Gcell.Value
End With
ActiveWorkbook.Close savechanges:=False
x = x + 1
Loop
End Sub
I have a code see below to import data from different workbooks inside one folder. I try it and it works perfectly however I was wondering if someone could help me to improve it.
I explain: "zmaster.xlms" workbook is the one where all data are past in sheet one. In this same workbook in sheet2 i have a table like this:
Where the column "Excel Column code" is where the data should be past (in the "zmaster.xlms") and "Form Cell Code" correspond to the cells which should be copy from every workbooks (which are in the same file in my desktop).
Question: How To say to the macro to look at the table and copy the cell K26 and past it in the columnA of the zmaster file and loop until the end of the table?
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\Desktop\New folder\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
' Range("A1:D1").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
MyFile = Dir
Loop
End Sub
Thank you in advance for your help!
All you need to do is to loop through the cells in sheet 2 (zmaster.xlsm). Have a look at example code. Please, read comments.
[EDIT]
Code has been updated!
Option Explicit
'assuming that:
'- "Excel Column Code" is in column A
'- "Form Cell Code" is in column B
'in zmaster.xlsm!Sheet2
Sub UpdateData()
Dim sFile As String, sPath As String
Dim srcWbk As Workbook, dstWbk As Workbook
Dim srcWsh As Worksheet, dstWsh As Worksheet, infoWsh As Worksheet
Dim i As Long, j As Long, k As Long
On Error GoTo Err_UpdateData
Set dstWbk = ThisWorkbook
Set dstWsh = dstWbk.Worksheets("Sheet1")
Set infoWsh = dstWbk.Worksheets("Sheet2")
sPath = "C:\Desktop\New folder\"
sFile = Dir(sPath)
Do While Len(sFile) > 0
If sFile = "zmaster.xlsm" Then
GoTo SkipNext
End If
Set srcWbk = Workbooks.Open(sPath & sFile)
Set srcWsh = srcWbk.Worksheets(1)
i = 2
'loop through the information about copy-paste method
Do While infoWsh.Range("A" & i) <> ""
'get first empty row, use "Excel Column Code" to get column name
j = GetFirstEmpty(dstWsh, infoWsh.Range("A" & i))
'copy data from source sheet to the destination sheet
'use "Form Cell Code" to define destination cell
srcWsh.Range(infoWsh.Range("B" & i)).Copy dstWsh.Range(infoWsh.Range("A" & i) & j)
i = i + 1
Loop
srcwbk.Close SaveChanges:=False
SkipNext:
sFile = Dir
Loop
Exit_UpdateData:
On Error Resume Next
Set srcWsh = Nothing
Set dstWsh = Nothing
Set srcWbk = Nothing
Set dstWbk = Nothing
Exit Sub
Err_UpdateData:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_UpdateData
End Sub
'returns first empty row in a destination sheet based on column name
Function GetFirstEmpty(ByVal wsh As Worksheet, Optional ByVal sCol As String = "A") As Long
GetFirstEmpty = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function
At the moment you code
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
is simply copying columns A to D of the first row of data in the source worksheet to a new row in the destination worksheet.
I'm assuming that you still want to create a new single row, but that you want the table on sheet2 to define which cells are put into which column of the new row.
you need to write something like this (which is untested):
Sub YourCode()
Dim MyFile As String
Dim erow
Dim Filepath As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsDestination As Worksheet
Dim rngMapping As Range
Dim DestinationRow As Long
Dim cell As Range
Filepath = "C:\Desktop\New folder\"
MyFile = Dir(Filepath)
Set wsDestination = ActiveWorkbook.Sheet1
' Named range "MappingTableFirstColumn" is defined as having the first column in the sheet2 table and all the rows of the table.
Set rngMapping = ActiveWorkbook.Names("MappingTable").RefersToRange
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Set wbSource = Workbooks.Open(Filepath & MyFile)
Set wsSource = wbSource.Sheets("Sheet1")
DestinationRow = wsDestination.Cells(wsDestination.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For Each cell In rngMapping
wsDestination.Range(cell.Value & DestinationRow) = wsSource.Range(cell.Offset(0, 1)).Value
Next cell
MyFile = Dir
Loop
ActiveWorkbook.Close
End Sub