I use the code below to loop through a range.
I need to change the sourceRange to a range in the Analysis v1 workbook.
In the Summary sheet of that workbook in cells B2 and B3 there are names of column headers in another sheet in that workbook called Data. The headers in the Data sheet are in row 2.
I would like to find the B2 and B3 column headers then loop through each column.
Option Explicit
Public Sub Process()
Dim targetWorkbook As Workbook
Dim summarySheet As Worksheet
Dim sourceRange As Range
Dim cell As Range
' Customize this settings
Set targetWorkbook = Workbooks("Analysis v1.xlsm")
Set summarySheet = ThisWorkbook.Worksheets("Summary")
Set sourceRange = summarySheet.Range("Q3:Q5")
Application.ScreenUpdating = False
' Loop through each cell in source range
For Each cell In sourceRange.Cells
' Validate that cell has a value
If cell.Value <> vbNullString Then
summarySheet.Range("F3").Value = cell.Value
' Execute procedure to create new sheet
CreateNewSheet
End If
Next cell
Application.ScreenUpdating = True
End Sub
Hi please check the following codes for your ref. Just show method of how to add / save a workbook.
Sub aa()
Dim targetWorkbook As Workbook
Dim summarySheet As Worksheet
Dim sourceRange As Range
Dim cell As Range
' Customize this settings
'Set targetWorkbook = Workbooks("Analysis v1.xlsm")
Set summarySheet = ThisWorkbook.Worksheets("Summary")
Set sourceRange = summarySheet.Range("Q3:Q5")
Application.ScreenUpdating = False
'not very clear for your logic ******
'Loop through each cell in source range
For Each cell In sourceRange.Cells
' Validate that cell has a value
If cell.Value <> vbNullString Then
summarySheet.Range("F3").Value = cell.Value
' Execute procedure to create new sheet
End If
Next cell
' *************************
'Here is the demo of how to copy and save to a new workbook.
Set targetWorkbook = Workbooks.Add
Dim fName As String
fName = "Analysis v1.xlsm"
targetWorkbook.Sheets(1).Range("A1") = summarySheet.Range("F3").Value
Application.DisplayAlerts = False
On Error Resume Next
targetWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & fName, FileFormat:=52
targetWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Related
I'm trying to copy and paste a certain value from a cell in one sheet matching a range in another workbook. The code runs fine, doesn't give any run-time errors, but will not paste in the range declared in the other workbook. Code below
Sub ConditionalCopy()
Dim dest As Worksheet
Set dest = ActiveWorkbook.Worksheets("VCP Plan")
Dim rng As Range, cell As Range
Set rng = Range("D:D")
Dim OpenWorkBook As Variant
OpenWorkBook = Application.GetOpenFilename("Excel Files (*.xlsx* (*.xlsx*),")
If OpenWorkBook <> False Then
Workbooks.Open (OpenWorkBook)
End If
For Each cell In rng
If cell.Value = "26ASA00015D007" Then
cell.Offset(0, 3).Copy Destination:=dest.Range("E3")
End If
Next cell
End Sub
It is unclear from your description and your code which workbook/worksheet you want to compare and copy, and which workbook/worksheet you want to copy to.
You'll need to be more specific
I've made a guess at what you are trying to do. If I've got it wrong, simply adjust the references to suit
Something like
Sub ConditionalCopy()
Dim wbSource as Workbook
Dim wsSource as Worksheet
Dim rSource as Range
Dim wbDest as Workbook
Dim wsDest as Worksheet
Dim rDest as Range
Set wbDest = ActiveWorkbook ' Are you sure?
Set wsDest = wbDest.Worksheets("VCP Plan")
Set rDest = ws.Range("E3")
Dim OpenWorkBook As Variant
OpenWorkBook = Application.GetOpenFilename("Excel Files (*.xlsx* (*.xlsx*),")
If OpenWorkBook <> False Then
Set wbSource = Workbooks.Open(OpenWorkBook)
Else
Exit Sub
End If
Set wsSource = wbSource.Worksheets("NameOfSourceSheet")
Dim cell As Range
With wsSource
' Column D from row 1 to last used row
Set rSource = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp))
End With
For Each cell In rSource
If cell.Value = "26ASA00015D007" Then
cell.Offset(0, 3).Copy Destination:=rDest
' You probably don't want to overwrite each time, so
Set rDest = rDest.Offset(1, 0)
End If
Next cell
End Sub
I need help with one aspect of my VBA code. I have a Master worksheet that houses data on all of my customers. I currently have code that looks at Column B (Customer Name Column) and creates new worksheets/tabs for each unique customer. I then want to cut and paste every row from my Master worksheet into individual respective worksheets based on the customer name. I've included a picture of my Master worksheet. I've also included the code I'm currently working with is below, it creates the new tabs but won't copy and paste.
Sub CreateWSandCopyPaste()
Application.ScreenUpdating = False
Dim cell As Range
Dim thisSheetName As String
AWS = ActiveSheet.Name
'Creates new worksheet/tab for every unique value in Column B (Customer Code Column)
For Each cell In Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
If (cell.Value <> "") Then
If (IsSheetExist(cell.Value) = False) Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = cell.Value
End If
End If
Next
'Copy and paste value A:U if the value in column B matches the tab name
Dim ws As Worksheet
For Each ws In Sheets
If ActiveSheet.Range("B2").Value = ws.Name Then
ActiveSheet.Range("A:U").CurrentRegion.Copy Destination:=ws.Range("A:U" & Rows.Count).End(x1Up)
End If
Next
Application.ScreenUpdating = True
End Sub
Private Function IsSheetExist(ByVal newSheetName As String)
Dim ws As Worksheet
For Each ws In Worksheets
If (ws.Name = newSheetName) Then
IsSheetExist = True
Exit Function
End If
Next
' ---
IsSheetExist = False
End Function
Master Worksheet - Customer Column
You can do it like this:
Sub CreateWSandCopyPaste()
Dim cell As Range, v
Dim thisSheetName As String, wb As Workbook, ws As Worksheet
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set wb = ws.Parent
'Creates new worksheet/tab for every unique value in Column B (Customer Code Column)
For Each cell In ws.Range(ws.Range("B2"), ws.Range("B" & Rows.Count).End(xlUp)).Cells
v = cell.Value
If Len(v) > 0 Then cell.EntireRow.Range("A1:U1").Copy _
GetSheet(v, wb).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next
Application.ScreenUpdating = True
End Sub
'Return a named sheet in wb (or create if doesn't exist)
Private Function GetSheet(ByVal SheetName As String, wb As Workbook)
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Worksheets(SheetName)
On Error GoTo 0
If ws Is Nothing Then
Set ws = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
ws.Name = SheetName
End If
Set GetSheet = ws
End Function
I modified code from Copy worksheet into different workbook replacing current data.
If I deselect range or I have selected different cell than A1, code falls into 1004 error.
Sub TG_update()
Dim wb1 As Workbook, wb2 As Workbook, ws1Format As Worksheet, ws2Format As Worksheet, ws3Format As Worksheet, ws4Format As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("[add your path.xlsx]")
Set ws1Format = wb1.Sheets("SheetA1")
Set ws2Format = wb2.Sheets("SheetB1")
Set ws3Format = wb1.Sheets("SheetA2")
Set ws4Format = wb2.Sheets("SheetB2")
'' Copy the cells of the "Format" worksheet.
ws2Format.Cells.Copy
'' Paste cells to the sheet "Format".
wb1.Sheets("SheetA1").Paste
ws4Format.Cells.Copy
wb1.Sheets("SheetB1").Paste
wb2.Close False 'remove false if you want to be asked if the workbook shall be saved.
wb1.Sheets("Store").Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Date successfully updated"
End Sub
Please try this code. Instead of copying and pasting millions of blank cells this code copies the worksheet from the source and pastes it to the workbook with the code. If the action is successful the old sheet is deleted. The final report alerts about errors if sheets weren't found.
Sub TG_update()
' 016
Dim Wb As Workbook ' ThisWorkbook
Dim WbS As Workbook ' Source
Dim Ffn As String ' Full FileName
Dim Ws As Worksheet
Dim TabName() As String
Dim i As Integer ' TabName index
Dim n As Integer ' tab counter
Set Wb = ThisWorkbook
' specify the workbook to be copied from: Full path and name
Ffn = "F:\AWK PC\Drive E (Archive)\PVT Archive\Class 1\1-2018 (Jan 2020)\TXL 180719 Z Distance.xlsm"
' enumerate the sheet names in CSV format (sheets must exist in Wb)
TabName = Split("SheetA1,SheetB1", ",")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set WbS = Workbooks.Open(Ffn)
For i = 0 To UBound(TabName)
On Error Resume Next ' suppress error if worksheet isn't found
WbS.Worksheets(TabName(i)).Copy After:=Wb.Worksheets(Wb.Worksheets.Count)
If Err.Number = 0 Then
n = n + 1
End If
Next i
WbS.Close SaveChanges:=False
On Error GoTo 0
For i = 0 To UBound(TabName)
For Each Ws In Wb.Worksheets
If InStr(Ws.Name, TabName(i) & " (") = 1 Then
Wb.Worksheets(TabName(i)).Delete
Ws.Name = TabName(i)
End If
Next Ws
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox n & " of " & i & " worksheets were successfully updated.", _
vbInformation, "Action report"
End Sub
Creative names like Wb1, Wb2, Ws1, Ws2, SheetA1, SheetA2 represent the punishment imaginative programmers inflict on those who come after them to correct their hastily concocted code. Give your VBA project a better reputation by bestowing names on your two worksheets that permit their identification.
The intent is to copy all unlocked cells in multiple sheets except "Sheet1" from Workbook1 (origin file) to Workbook2 (destination file) which contains worksheets with the same names as Workbook1.
Workbook1 is a checklist and Workbook2 is an updated version with additions of new worksheets or extra unlocked cells. The workbook and worksheet names are different from above but have renamed everything for simplicity.
I put some code together:
Sub ImportData()
Dim vFile As Variant, wbCopyTo As Workbook, wsCopyTo As Worksheet, _
wbCopyFrom As Workbook, wsCopyFrom As Worksheet, WorkRng As Range, _
OutRng As Range, Rng As Range
Application.ScreenUpdating = False
Set wbCopyTo = ActiveWorkbook 'sets Workbook2 to destination file
'this allows user to select old file Workbook1
' - the workbook name may be different in practice
' hence the ability to choose file
vFile = Application.GetOpenFilename("All Excel Files (*.xls*)," & _
"*.xls*", 1, "Select your old file", "Open", False)
If TypeName(vFile) = "Boolean" Then
Exit Sub 'check file selected is okay to use else exits sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
End If 'sets Workbook1 to origin file
For Each Worksheet In wbCopyFrom.Worksheets
'should loop each worksheet, I think the error is part of this For statement
If Worksheet.Name <> "Sheet1" Then
On Error Resume Next
Set wsCopyFrom = Worksheet 'sets Sheet2 to origin sheet
'sets sheet matching name on previous line in Workbook2
' to destination sheet
Set wsCopyTo = wbCopyTo.Worksheets(Worksheet.Name)
wbCopyFrom.Activate
wsCopyFrom.Select 'selects origin sheet
Set WorkRng = wsCopyFrom.UsedRange
For Each Rng In WorkRng
If Rng.Locked = False Then
If OutRng.Count = 0 Then
Set OutRng = Rng
Else
Set OutRng = Union(OutRng, Rng)
End If
End If
Next
'a loop I found to pick all unlocked cells,
' seems to work fine for first sheet
If OutRng.Count > 0 Then OutRng.Select
Dim rCell As Range
For Each rCell In Selection.Cells
rCell.Copy Destination:=wsCopyTo.Cells(rCell.Row, rCell.Column)
'a loop to copy all unlocked cells exactly as is
' in terms of cell reference on sheet,
' seems to work fine for first sheet
Next rCell
End If
'should go to Sheet3 next, seems to go to the sheet
' but then doesn't select any unlocked cells nor copy anything across
Next Worksheet
wbCopyFrom.Close SaveChanges:=False 'closes origin file Workbook1
Application.ScreenUpdating = True
End Sub
It will select and copy all unlocked cells from "Sheet2" in Workbook1 to "Sheet2" in Workbook2, however, it will not cycle through all of the sheets necessary ("Sheet3" onwards).
it's possible your use of On Error Resume Next is masking problems
use something other than Worksheet as your For Each loop variable name
you don't reset OutRng after each worksheet
Try something like this:
Sub ImportData()
Dim vFile As Variant, wbCopyTo As Workbook, wsCopyTo As Worksheet, _
wbCopyFrom As Workbook, OutRng As Range, c As Range, wsCopyFrom As Worksheet
Application.ScreenUpdating = False
Set wbCopyTo = ActiveWorkbook 'sets Workbook2 to destination file
vFile = Application.GetOpenFilename("All Excel Files (*.xls*)," & _
"*.xls*", 1, "Select your old file", "Open", False)
If TypeName(vFile) = "Boolean" Then Exit Sub
Set wbCopyFrom = Workbooks.Open(vFile)
For Each wsCopyFrom In wbCopyFrom.Worksheets
If wsCopyFrom.Name <> "Sheet1" Then
Set wsCopyTo = wbCopyTo.Worksheets(wsCopyFrom.Name)
Set OutRng = UsedRangeUnlocked(wsCopyFrom)
If Not OutRng Is Nothing Then
For Each c In OutRng
c.Copy wsCopyTo.Range(c.Address)
Next c
End If
End If
Next wsCopyFrom
wbCopyFrom.Close SaveChanges:=False 'closes origin file Workbook1
Application.ScreenUpdating = True
End Sub
'return a range containing all unlocked cells within the UsedRange of a worksheet
Function UsedRangeUnlocked(sht As Worksheet) As Range
Dim rngUL As Range, c As Range
For Each c In sht.UsedRange.Cells
If Not c.Locked Then
If rngUL Is Nothing Then
Set rngUL = c
Else
Set rngUL = Application.Union(rngUL, c)
End If
End If
Next c
Set UsedRangeUnlocked = rngUL
End Function
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