I am trying to create a backup copy with VBA. The problem is, that everything except the row height is being copied. I tried looking for an answer, but couldnt find anything that fits.
Here's my code:
Application.Workbooks.Add ' Neue Mappe erstellen
Dim counter As Integer
Dim wbNew As Workbook
Dim shtOld, shtNew As Worksheet
Dim pfad As String
Dim name As String
pfad = ThisWorkbook.Path
name = Left(ThisWorkbook.name, Len(ThisWorkbook.name) - 5)
'MsgBox "Aktueller Pfad: " & ThisWorkbook.Path
'MsgBox Left(ThisWorkbook.name, Len(ThisWorkbook.name) - 5)
Set wbNew = Application.Workbooks(Application.Workbooks.Count)
Do While wbNew.Worksheets.Count < ThisWorkbook.Worksheets.Count
wbNew.Worksheets.Add ' Weitere Tabellen hinzufügen, falls nötig
Loop
' Tabellen kopieren
For counter = 1 To ThisWorkbook.Worksheets.Count
Set shtOld = ThisWorkbook.Worksheets(counter) ' Quelltabelle
Set shtNew = wbNew.Worksheets(counter) ' Zieltabelle
shtNew.name = shtOld.name ' Tabellenname übernehmen
shtOld.UsedRange.Copy ' Quelldaten und -format kopieren
shtNew.Range("A1").PasteSpecial Paste:=8 ' Spaltenbreite übernehmen
shtNew.UsedRange.PasteSpecial xlPasteValues ' Werte einfügen
shtNew.UsedRange.PasteSpecial xlPasteFormats ' Format übernehmen
Next
wbNew.SaveAs pfad & "\" & name & " " & Format(Now, "YYYYMMDD hhmm") & ".xlsx"
Application.CutCopyMode = False ' Zwischenspeicher löschen
'
Anyone got an idea? Would be great!
You want to assign the height, rather than copy/paste formatting. The code below should get you started:
Sub RowHeight()
Dim wsOne As Worksheet: Set wsOne = ActiveWorkbook.Sheets("Sheet1")
Dim wsTwo As Worksheet: Set wsTwo = ActiveWorkbook.Sheets("Sheet2")
Dim RowHght As Long
RowHght = wsOne.Range("A1").EntireRow.Height
wsTwo.Range("A1:A10").RowHeight = RowHght
End Sub
If I understand correctly then you are trying to save thisWorkBook with a new name as a backup. This code should do it a little more efficiently.
Sub saveCopyOfThisWorkBookWithNewName()
Dim fileFrmt As Long, oldFileName As String, newFileName As String
fileFrmt = ActiveWorkbook.FileFormat
oldFileName = ThisWorkbook.FullName
newFileName = Left(oldFileName, InStrRev(oldFileName, ".") - 1) & "_" & CStr(Format(Now, "YYYYMMDD hhmm"))
ThisWorkbook.SaveCopyAs Filename:=newFileName & ".xlsx"
End Sub
You need to select, copy and paste the rows to get the row heights to paste across
Related
I would like to create new files (in the same folder) from sheet "lista strategiczna".D2 only if doesn't exist. Next offset one position down, and create next files etc. What I doing wrong?
Sub TworzenieZamowien()
Dim thisWb As Workbook
Dim nazwaPliku As String
Set thisWb = ActiveWorkbook
Dim aktywnaKomorka As Range
Set aktywnaKomorka = Sheets("lista strategiczna").Range("D2")
Dim FilePath As String
FilePath = Dir(ActiveWorkbook.Path, vbDirectory)
Do Until aktywnaKomorka = ""
nazwaPliku = thisWb.Path & "\Zamówienie " & aktywnaKomorka & ".xls"
If FilePath <> nazwaPliku Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=nazwaPliku
ActiveWorkbook.Close savechanges:=False
aktywnaKomorka.Offset(1, 0).Select
Else
aktywnaKomorka.Offset(1, 0).Select
End If
Loop
End Sub
I would set your range at the start, use a For loop and do away with selecting things (rarely a good idea). Your current code doesn't change aktywnaKomorka(it remains D2), you just activate the next cell below but your loop does not reference the active cell.
Sub TworzenieZamowien()
Dim thisWb As Workbook
Dim nazwaPliku As String
Set thisWb = ActiveWorkbook
Dim aktywnaKomorka As Range
With Sheets("lista strategiczna")
Set aktywnaKomorka = .Range("D2", .Range("D" & Rows.Count).End(xlUp))
End With
Dim FilePath As String, r As Range
FilePath = Dir(ActiveWorkbook.Path, vbDirectory)
For Each r In aktywnaKomorka
If r <> vbNullString Then
nazwaPliku = thisWb.Path & "\Zamówienie " & r & ".xls"
If FilePath <> nazwaPliku Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=nazwaPliku
ActiveWorkbook.Close savechanges:=False
End If
End If
Loop
End Sub
If you wanted to persist with your Do loop rather than Select add this line
set aktywnaKomorka=aktywnaKomorka.Offset(1, 0)
Looking to loop the following code through (about) 125 worksheets in an Excel workbook and pull the listed cell values into one database entry log on the 'Database' worksheet'. Right now it is only pulling from one of the tabs . (PO VT-0189). Wondering how to correct.
Private Sub PopulateOrderInfo()
Dim OrderDate As String, PONumber As String, Vendor As String, ShipTo As String, SKU As String
Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet
For Each OFrm In ActiveWorkbook.Worksheets
Set OFrm = Worksheets("PO VT-0189")
Set DB = Worksheets("Database")
OrderDate = OFrm.Range("N4")
PONumber = OFrm.Range("N3")
Vendor = OFrm.Range("A13")
ShipTo = OFrm.Range("I13")
POTotal = OFrm.Range("P43")
LastSKURow = OFrm.Range("A38").End(xlUp).Row
For R = 21 To LastSKURow
SKU = OFrm.Range("A" & R).Value
SKUDesc = OFrm.Range("D" & R).Value
SKUQty = OFrm.Range("K" & R).Value
Lntotal = OFrm.Range("M" & R).Value
NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1
DB.Range("A" & NextDBRow).Value = OrderDate
DB.Range("B" & NextDBRow).Value = PONumber
DB.Range("C" & NextDBRow).Value = Vendor
DB.Range("D" & NextDBRow).Value = ShipTo
DB.Range("E" & NextDBRow).Value = SKU
DB.Range("F" & NextDBRow).Value = SKUDesc
DB.Range("G" & NextDBRow).Value = SKUQty
DB.Range("H" & NextDBRow).Value = Lntotal
DB.Range("I" & NextDBRow).Value = POTotal
Next R
Next OFrm
End Sub
I think you can also shorten your code by avoiding the loop and most of the variables seem unnecessary to me.
Private Sub PopulateOrderInfo()
Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet
Set DB = Worksheets("Database")
For Each OFrm In ActiveWorkbook.Worksheets
If OFrm.Name <> DB.Name Then
LastSKURow = OFrm.Range("A38").End(xlUp).Row
R = LastSKURow - 21 + 1
NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1
DB.Range("A" & NextDBRow).Resize(R).Value = OFrm.Range("N4")
DB.Range("B" & NextDBRow).Resize(R).Value = OFrm.Range("N3")
DB.Range("C" & NextDBRow).Resize(R).Value = OFrm.Range("A13")
DB.Range("D" & NextDBRow).Resize(R).Value = OFrm.Range("I13")
DB.Range("E" & NextDBRow).Resize(R).Value = OFrm.Range("A21").Resize(R).Value
DB.Range("F" & NextDBRow).Resize(R).Value = OFrm.Range("D21").Resize(R).Value
DB.Range("G" & NextDBRow).Resize(R).Value = OFrm.Range("K21").Resize(R).Value
DB.Range("H" & NextDBRow).Resize(R).Value = OFrm.Range("M21").Resize(R).Value
DB.Range("I" & NextDBRow).Resize(R).Value = OFrm.Range("P43")
End If
Next OFrm
End Sub
Use a for loop and WorkSheets collection like:
For I = 1 to worksheets.count
if worksheets(i).name <> "Database" then
Add your code here
end if
Next i
This loops through every worksheet in your workbook and does what ever you need to all worksheets except the Database.
Using a for each... loop
For Each ws In wb.Worksheets
If ws.name = "Database" Then
'Leave blank to just skip database. Code here if you want something special on database. OR statements can be used to exclude additional sheets
Else
'Code here
End If
Next
I think you described the issue fairly well. Just to confirm, you want to loop through all worksheets in one single workbook, right. Try the script below. Feedback if you have additional questions, concerns, etc. Thanks.
Sub ImportAll()
Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
Dim lngCount As Long
Dim objExcel As Object, objWorkbook As Object
Dim colWorksheets As Collection
Dim strPathFile as String, strTable as String
Dim strPassword As String
' Establish an EXCEL application object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set objExcel = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = False
' Replace C:\Filename.xls with the actual path and filename
strPathFile = "C:\Filename.xls"
' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "tablename"
' Replace passwordtext with the real password;
' if there is no password, replace it with vbNullString constant
' (e.g., strPassword = vbNullString)
strPassword = "passwordtext"
blnReadOnly = True ' open EXCEL file in read-only mode
' Open the EXCEL file and read the worksheet names into a collection
Set colWorksheets = New Collection
Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , _
strPassword)
For lngCount = 1 To objWorkbook.Worksheets.Count
colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
Next lngCount
' Close the EXCEL file without saving the file, and clean up the EXCEL objects
objWorkbook.Close False
Set objWorkbook = Nothing
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing
' Import the data from each worksheet into the table
For lngCount = colWorksheets.Count To 1 Step -1
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$"
Next lngCount
' Delete the collection
Set colWorksheets = Nothing
' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile
End Sub
I'm trying to write a VBA macro that changes file names from the text in Column B to the text of Column A. For example, if I had:
Column A: Stack Overflow
Column B: Question
It would change Question.txt to Stack Overflow.txt. As of now I've slightly modified the code from the answer here to read:
Sub rename()
Dim Source As Range
Dim OldFile As String
Dim NewFile As String
Set Source = Cells(1, 1).CurrentRegion
For Row = 2 To Source.Rows.Count
OldFile = ActiveSheet.Range("D1").Value & ("\") & ActiveSheet.Cells(Row, 1) & (".pdf")
NewFile = ActiveSheet.Range("D1").Value & ("\") & ActiveSheet.Cells(Row, 2) & (".pdf")
' rename files
Name OldFile As NewFile
Next
End Sub
This works great, but I'm trying to get it to only run on selected rows; my ideal end result is that I can select the 15 non-consecutive rows that I want to change, run the macro, and have it only apply to those 15. I tried the below code but the ActiveSheet.Cells(Row, 1) function is returning a Run-Time Error 1004, Application-defined or object-definied error; is there a good way around this?
Sub renameMain()
Dim OldFile As String
Dim NewFile As String
Dim rng As Range
Set rng = Selection
For Each Row In rng
OldFile = ActiveSheet.Range("O1").Value & "\" & ActiveSheet.Range(Row, 2) & ".pdf"
NewFile = ActiveSheet.Range("O1").Value & "\" & ActiveSheet.Range(Row, 1) & ".pdf"
' rename files
Name OldFile As NewFile
Next Row
End Sub
Any advice would be much appreciated!
Non contiguous rows in the Selection object can be accessed using its .Areas collection:
Option Explicit
Sub renameMain()
Dim oldFile As String, newFile As String
Dim selArea As Range, selRow As Range, staticVal As String
With ActiveSheet
staticVal = .Range("O1").Value2 & "\"
For Each selArea In Selection.Areas
For Each selRow In selArea.Rows
oldFile = staticVal & .Cells(selRow.Row, 2).Value2
newFile = staticVal & .Cells(selRow.Row, 1).Value2
Name oldFile & ".pdf" As newFile & ".pdf" 'rename files
Next
Next
End With
End Sub
You seem to want to use Row as an int variable. It isn't. Maybe try this:
Sub renameMain()
Dim OldFile As String
Dim NewFile As String
Dim rng As Range
Dim i as long
Set rng = Selection
For i = 1 To rng.Rows.Count
OldFile = ActiveSheet.Range("O1").Value & "\" & rng.Cells(i, 2) & ".pdf"
NewFile = ActiveSheet.Range("O1").Value & "\" & rng.Cells(i, 1) & ".pdf"
' rename files
Name OldFile As NewFile
Next i
End Sub
I am trying to copy data from a couple of workbooks present in a folder into a single workbook. I am looping through the folder to fetch the data from the various workbooks but I need to paste the data spanning from A5:D5 in loop.
i.e A5:D5 in the destination sheet is one workbook's data in the folder, I need the other set of data to be copied into A6:D6 and so on for the number of workbooks in the folder. Please help me loop through this.
Private Sub CommandButton1_Click()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Path = "D:\Macro_Demo\estimation_sheets\"
Filename = Dir(Path & "*.xls")
Set target = Workbooks.Open("D:\Macro_Demo\Metrics_Macro_dest")
'--------------------------------------------
'OPEN EXCEL FILES
Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
Set wbk = Workbooks.Open(Path & Filename)
target.Sheets("Metrics_Data").Range("A5").Value = wbk.Sheets("summary").Range("I5").Value
target.Sheets("Metrics_Data").Range("B5").Value = wbk.Sheets("summary").Range("I6").Value + wbk.Sheets("summary").Range("I7")
target.Sheets("Metrics_Data").Range("C5").Value = wbk.Sheets("summary").Range("I8").Value
target.Sheets("Metrics_Data").Range("D5").Value = wbk.Sheets("summary").Range("I9").Value
MsgBox Filename & " has opened"
wbk.Close True
Filename = Dir
Loop
MsgBox "Task complete!"
End Sub
Try this:
Private Sub CommandButton1_Click()
Dim wbk As Workbook, target As Workbook, excelFile As String, path As String, rw As Integer
path = "D:\Macro_Demo\estimation_sheets\"
excelFile = Dir(path & "*.xls")
rw = 5
Set target = Workbooks.Open("D:\Macro_Demo\Metrics_Macro_dest")
Do While excelFile <> ""
Set wbk = Workbooks.Open(path & excelFile)
With target.Sheets("Metrics_Data")
.Range("A" & rw) = wbk.Sheets("summary").Range("I5")
.Range("B" & rw) = wbk.Sheets("summary").Range("I6") + wbk.Sheets("summary").Range("I7")
.Range("C" & rw) = wbk.Sheets("summary").Range("I8")
.Range("D" & rw) = wbk.Sheets("summary").Range("I9")
End With
wbk.Close True
rw = rw + 1
excelFile = Dir
Loop
MsgBox "Task complete!"
End Sub
You need to find the next available row on your destination sheet, store that in a variable, and write the data relative to that cell. Like this
Private Sub CommandButton1_Click()
Dim shSource As Worksheet, shDest As Worksheet
Dim sFile As String
Dim rNextRow As Range
Const sPATH As String = "D:\Macro_Demo\estimation_sheets\"
'Open the destination workbook
Set shDest = Workbooks.Open("D:\Macro_Demo\Metrics_Macro_dest.xls").Worksheets("Metrics_Data")
sFile = Dir(sPATH & "*.xls")
Do While Len(sFile) > 0
Set shSource = Workbooks.Open(sPATH & sFile).Worksheets("summary")
'start at row 1000 and go up until you find something
'then go down one row
Set rNextRow = shDest.Cells(1000, 1).End(xlUp).Offset(1, 0)
'Write the values relative to rNextRow
With rNextRow
.Value = shSource.Range("I5").Value
.Offset(0, 1).Value = shSource.Range("I6").Value
.Offset(0, 2).Value = shSource.Range("I8").Value
.Offset(0, 3).Value = shSource.Range("I9").Value
End With
'Close the source
shSource.Parent.Close False
sFile = Dir
Loop
MsgBox "Done"
End Sub
I wanted to write a code for macro, that will load files from my local directory into excel sheet of Column say ("C"), the names on files should match names on Column ("B"). If any of the files doesn't find for the names given in column B it should skip that row of loading files and continues to next column. I'am difficulty in writing as I am new to VB. I tried somehow but, my script working to load files from directory and loading names. Please help!! thank you all,
Code:
Sub Insert_OLE_Object()
Dim mainWorkBook As Workbook
Set mainWorkBook = ActiveWorkbook
Set ActiveSheet = example1
Folderpath = "C:\Documents and Settings\my\Desktop\folder1"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
For Each fls In listfiles
Counter = Counter + 1
Range("B" & Counter).Value = fls.Name
strCompFilePath = Folderpath & "\" & Trim(fls.Name)
If strCompFilePath <> "" Then
Worksheets("Example1").OLEObjects.Add(Filename:=strCompFilePath, Link:=False, DisplayAsIcon:=True, IconIndex:=1, IconLabel:=strCompFilePath, Left:=20, Top:=40, Width:=150, Height:=10).Select
Sheets("example1").Activate
Sheets("example1").Range("C" & ((Counter - 1) * 3) + 1).Select
End If
Next
End Sub
Try this code:
Sub Insert_OLE_Object()
Dim ws As Worksheet
Dim rng As Range, c As Range
Dim strCompFilePath As String, Folderpath As String, fullpath As String
Dim obj As Object
Application.ScreenUpdating = False
'change to suit
Set ws = ThisWorkbook.Worksheets("Example1")
'change B1:B5 to suit
Set rng = ws.Range("B1:B5")
Folderpath = "C:\Documents and Settings\my\Desktop\folder1"
For Each c In rng
strCompFilePath = Dir(Folderpath & "\" & Trim(c.Value) & ".*")
'if file with this name found, embed it
If strCompFilePath <> "" Then
fullpath = Folderpath & "\" & strCompFilePath
Set obj = ws.OLEObjects.Add(Filename:=fullpath, Link:=False, _
DisplayAsIcon:=True, IconIndex:=1, _
IconLabel:=fullpath)
With obj
.Left = c.Offset(, 1).Left
.Top = c.Offset(, 1).Top
.Width = c.Offset(, 1).ColumnWidth
.Height = c.Offset(, 1).RowHeight
End With
End If
Next
Application.ScreenUpdating = True
End Sub