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
I have a problem with data import. I am using the following code to import data from another CSV.
Sub Import(ByVal sFileName As String)
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range
Set wb1 = ActiveWorkbook
Set PasteStart = [DATA!A1]
'Clean Data Sheet
Sheets("DATA").Select
Cells.Select
Selection.ClearContents
If IsEmpty(sFileName) Then
MsgBox "No File Specified.", vbExclamation, "ERROR"
Exit Sub
Else
Set wb2 = Workbooks.Open(Filename:=sFileName, Delimiter:=";")
For Each Sheet In wb2.Sheets
With Sheet.UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
Next Sheet
End If
wb2.Close
'Text to Column if needed
Call TextToColumnSemiToComa
'Activate Home Sheet
Worksheets("Netherland DCA").Activate
'Complete message
MsgBox ("Data Import Complete")
End Sub
The problem is that the macro changes dates. For ex. the original file has 12/10/2019(dd/mm/yyyy), but after import its 10/12/2019(dd/mm/yyyy). Do you know where could be problem?
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
I have a master spreadsheet Master Spreadsheet.xlsm and I want to use it to create another spreadsheet defined by OutputFN.
This second spreadsheet needs to be a copy of the first but only containing the visible cells from visible worksheets in the first.
I have found code to copy just the visible sheets and other code to copy just the visible cells but not the two together. Any help would be much appreciated.
This is what I've got so far:
Private Sub saveone()
Dim OutputFN As String
Dim OutputWB As Workbook
Dim SourceWB As Workbook
Dim i As Integer
i = 1
Set SourceWB = Application.ActiveWorkbook
OutputFN = ThisWorkbook.Worksheets("Setup Page").Range("B12").Value
Set OutputWB = Workbooks.Add
'Selects active (not hidden cells) from visible sheets and copies
For Each Sheet In ThisWorkbook.Sheets
If Sheet.Visible = True Then
ThisWorkbook.ActiveSheet.Cells. _
SpecialCells(xlCellTypeVisible).Copy
'Pastes into new workbook
Worksheets(i).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
'Saves new file as output filename in the directory created earlier
ActiveWorkbook.SaveAs (OutputFN)
i = i + 1
End If
Next
End Sub
Something like this
I've tidied up the variables and tweaked the logic a little as well
Private Sub saveone()
Dim OutputFN As String
Dim OutputWB As Workbook
Dim SourceWB As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Set SourceWB = ThisWorkbook
OutputFN = SourceWB.Worksheets("Setup Page").Range("B12").Value
Set OutputWB = Workbooks.Add(1)
Application.ScreenUpdating = False
For Each ws In SourceWB.Sheets
If ws.Visible Then
Set ws2 = OutputWB.Sheets.Add(After:=OutputWB.Sheets(OutputWB.Sheets.Count))
ws.Cells.SpecialCells(xlCellTypeVisible).Copy
ws2.[a1].PasteSpecial xlPasteValues
ws2.[a1].PasteSpecial xlPasteFormats
End If
Next
Application.ScreenUpdating = True
ActiveWorkbook.SaveAs (OutputFN)
End Sub
I want to create a button in excel sheet which will copy a particular range(named range) and then open a Save As dialog box and user can select the location and save that range as a new excel sheet. Is this possible?
I am able to write a code which copies the named range to clipboard and then user can paste it into MS word etc. Below is the code I have till now.
Sub copyValueTable()
Dim oRange As Range
Set oRange = Sheets("Analysis").Range("FullValueTable")
oRange.CopyPicture xlScreen, xlPicture
oRange.Copy
End Sub
Try below code :
Sub copyValueTable()
On Error Resume Next
Dim rng As Range
Dim wkb As Workbook
Dim sht As Worksheet
Set rng = Application.InputBox("Please select the range" & vbNewLine & "Enter named range", Type:=8)
On Error GoTo 0
If Not rng Is Nothing Then
fileSaveName = Application.GetSaveAsFilename(fileFilter:="xls Files (*.xls), *.xls")
If fileSaveName <> False Then
ActiveSheet.Copy
Set wkb = ActiveWorkbook
Set sht = wkb.Sheets(1)
sht.Cells.Clear
rng.Copy sht.Range("A1")
wkb.SaveAs fileSaveName
wkb.Close
End If
End If
End Sub