Posts by royUK

royUK · 2020-03-30T07:53:31+01:00

This sets the filters for GestSaveAsFileName.

Code

Option Explicit
Sub FilterAndExport()
Dim oWb As Workbook, oNewWb As Workbook
Dim oWs As Worksheet
Dim rRng As Range
Dim iX As Integer
Dim sCode As String, vNewname
On Error GoTo exit_proc
Application.ScreenUpdating = False
''/// the activeworkbook must be the original data workbook
Set oWb = ActiveWorkbook
''///create new workbook
Set oNewWb = Workbooks.Add
''///add 5 sheets
Application.SheetsInNewWorkbook = 5
sCode = InputBox("Enter Dealer Code", "Filter Criteria")
If sCode = Empty Then
MsgBox "No code entered.", vbCritical, "User cancelled"
ActiveWorkbook.Close False
Exit Sub
End If
iX = 1
For Each oWs In oWb.Worksheets
With oWs
If Not .AutoFilterMode Then .Range("A1").AutoFilter
.Range("A1").AutoFilter Field:=1, Criteria1:=sCode
Set rRng = .AutoFilter.Range
rRng.Copy
With oNewWb
.Sheets(iX).Range("A1").PasteSpecial xlAll
.Sheets(iX).Range("A1").CurrentRegion.Cells.WrapText = False
.Sheets(iX).Range("A1").CurrentRegion.Columns.AutoFit
.Sheets(iX).Name = oWs.Name
End With
iX = iX + 1
End With
Next oWs
vNewname = Application.GetSaveAsFilename(FileFilter:= _
"Excel Files (*.xls*)," & "*.xls*")
If vNewname <> False Then ActiveWorkbook.SaveAs Filename:=vNewname, FileFormat:=51
exit_proc:
Application.ScreenUpdating = True
End Sub

Display More

What Format do you need to add?

royUK · 2020-03-29T18:04:59+01:00

I'll take another look tomorrow

royUK · 2020-03-29T17:46:45+01:00

The code that I gave you will loop through the cells until it reaches an empty cell.

I've looked at your last workbook and this code runs fine

Code

Sub Import()
Dim iX As Integer
If ActiveCell.Address <> "A1" Then Range("A1").Select
With ActiveCell
Do Until IsEmpty(ActiveCell)
iX = ActiveCell.Value
Blad2.Cells(2, 1 + iX) = Blad2.Cells(2, 1 + iX) + 1
ActiveCell.Offset(1, 0).Select 'Select the next cell (the cell below: offset(1,0)
Loop
End With
End Sub

Display More

Your unused code needs deleting

royUK · 2020-03-29T17:09:48+01:00

You won't learn in a week or so, but just keep on trying and asking questions, especially if you do not understand something in the code that you see.

royUK · 2020-03-29T17:01:41+01:00

What do you mean

Quote

why it's not possible to let a macro run based on the import results.

royUK · 2020-03-29T16:58:11+01:00

Your code seems to loop through the hyperlinks in the workbook that you attached to copy files from that hyperlink. It's difficult to test the code because I don't have the required files.

What is actually happening?

royUK · 2020-03-29T16:54:26+01:00

Pleased to help. Does it work OK now?

royUK · 2020-03-29T16:47:40+01:00

Your formatting macros will slow the code down, my code copies formats from the original sheet. I thought they looked the same.

royUK · 2020-03-29T16:41:14+01:00

This should work from your personal workbook

Code

Option Explicit
Sub FilterAndExport()
Dim oWb As Workbook, oNewWb As Workbook
Dim oWs As Worksheet
Dim rRng As Range
Dim iX As Integer
Dim sCode As String, vNewname
On Error GoTo exit_proc
Application.ScreenUpdating = False
''/// the activeworkbook must be the original data workbook
Set oWb = ActiveWorkbook
''///create new workbook
Set oNewWb = Workbooks.Add
''///add 5 sheets
Application.SheetsInNewWorkbook = 5
sCode = InputBox("Enter Dealer Code", "Filter Criteria")
If sCode = Empty Then
MsgBox "No code entered.", vbCritical, "User cancelled"
ActiveWorkbook.Close False
Exit Sub
End If
iX = 1
For Each oWs In oWb.Worksheets
With oWs
If Not .AutoFilterMode Then .Range("A1").AutoFilter
.Range("A1").AutoFilter Field:=1, Criteria1:=sCode
Set rRng = .AutoFilter.Range
rRng.Copy
With oNewWb
.Sheets(iX).Range("A1").PasteSpecial xlAll
.Sheets(iX).Range("A1").CurrentRegion.Cells.WrapText = False
.Sheets(iX).Range("A1").CurrentRegion.Columns.AutoFit
.Sheets(iX).Name = oWs.Name
End With
iX = iX + 1
End With
Next oWs
vNewname = Application.GetSaveAsFilename
If vNewname <> False Then ActiveWorkbook.SaveAs Filename:=vNewname, FileFormat:=51
exit_proc:
Application.ScreenUpdating = True
End Sub

Display More

royUK · 2020-03-29T16:38:10+01:00

The code isn't written for an addin or PERSONAL.xlsb, it was written to run from the source workbook,

I can make adjustments for you.

royUK · 2020-03-29T15:42:57+01:00

I cannot replicate that error. I've run the code successfully twice since my last reply

Just run it again with no errors and noticed that in total I have run it 33 times without that error.

Where have you put the code?

Attach the file that has the code in it

royUK · 2020-03-29T15:21:11+01:00

Pleased to help.

royUK · 2020-03-29T15:04:20+01:00

No error at all for me. I've run it several times.

The AutoFilter takes place in the original workbook

Are you using the same example workbook? Does each sheet have data starting in A1?

Line 26 checks if AutoFilter is on, if it isn't then it switches it on, if there is no data in A1 then it will error

Code

If Not .AutoFilterMode Then .Range("A1").AutoFilter

royUK · 2020-03-29T14:43:39+01:00

Try this, it removes the data that has been transferred

Code

Sub copycolumns()
Dim lastrow As Long, erow As Long
lastrow = sheet2.Cells(sheet2.Rows.Count, 1).End(xlUp).Row
erow = sheet4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With sheet2
.Range(.Cells(2, 2), .Cells(lastrow, 2)).Copy sheet4.Cells(erow, 3)
.Range(.Cells(2, 2), .Cells(lastrow, 2)).ClearContents
.Range(.Cells(2, 1), .Cells(lastrow, 1)).Copy sheet4.Cells(erow, 5)
.Range(.Cells(2, 1), .Cells(lastrow, 1)).ClearContents
.Range(.Cells(2, 5), .Cells(lastrow, 5)).Copy sheet4.Cells(erow, 7)
.Range(.Cells(2, 5), .Cells(lastrow, 5)).ClearContents
End With
End Sub

Display More

royUK · 2020-03-29T14:27:02+01:00

So you don't need to delete all the data in Sheet2?

royUK · 2020-03-29T13:27:31+01:00

Your original code cannot work for anyone.

The Loop is unnecessary

This Range is only one cell

Code

sheet2.Cells(i, 2).Copy

Compare it to my ranges to copy

What do you want to clear?

royUK · 2020-03-29T13:04:59+01:00

You aren't setting the ranges correctly.

I can't understand what your loop is for.

I think this is doing what you want

Code

Sub copycolumns()
Dim lastrow As Long, erow As Long
lastrow = sheet2.Cells(Rows.Count, 1).End(xlUp).Row
erow = sheet4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With sheet2
.Range(.Cells(2, 2), .Cells(lastrow, 2)).Copy sheet4.Cells(erow, 3)
.Range(.Cells(2, 1), .Cells(lastrow, 1)).Copy sheet4.Cells(erow, 5)
.Range(.Cells(2, 5), .Cells(lastrow, 5)).Copy sheet4.Cells(erow, 7)
End With
End Sub

Display More

royUK · 2020-03-29T12:50:15+01:00

What exactly are you trying to do?

What is not copying?

royUK · 2020-03-29T12:11:45+01:00

I think this does all you want

Code

Option Explicit
Sub FilterAndExport()
Dim oWb As Workbook, oNewWb As Workbook
Dim oWs As Worksheet
Dim rRng As Range
Dim iX As Integer
Dim sCode As String, vNewname
Set oNewWb = ActiveWorkbook
''///create new workbook
Set oNewWb = Workbooks.Add
''///add 5 sheets
Application.SheetsInNewWorkbook = 5
sCode = InputBox("Enter Dealer Code", "Filter Criteria")
If sCode = Empty Then
MsgBox "No code entered.", vbCritical, "User cancelled"
ActiveWorkbook.Close False
Exit Sub
End If
iX = 1
For Each oWs In ThisWorkbook.Worksheets
With oWs
If Not .AutoFilterMode Then .Range("A1").AutoFilter
.Range("A1").AutoFilter Field:=1, Criteria1:=sCode
''///set a range = to visible cells (excluding the header)
Set rRng = .AutoFilter.Range
rRng.Copy
With oNewWb
.Sheets(iX).Range("A1").PasteSpecial xlAll
.Sheets(iX).Range("A1").CurrentRegion.Cells.WrapText = False
.Sheets(iX).Range("A1").CurrentRegion.Columns.AutoFit
.Sheets(iX).Name = oWs.Name
End With
iX = iX + 1
End With
Next oWs
vNewname = Application.GetSaveAsFilename
If vNewname <> False Then ActiveWorkbook.SaveAs Filename:=vNewname, FileFormat:=51
End Sub

Display More

royUK · 2020-03-29T09:44:53+01:00

You could actually simply use COUNTIF to get the scores

Posts by royUK

AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets

AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets

Run Macro Based On Values In Column

AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets

Run Macro Based On Values In Column

Copy x times of file into a new folder

AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets

AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets

AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets

AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets

AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets

problem transfer data of specific columns from sheet to another

AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets

problem transfer data of specific columns from sheet to another

problem transfer data of specific columns from sheet to another

problem transfer data of specific columns from sheet to another

problem transfer data of specific columns from sheet to another

problem transfer data of specific columns from sheet to another

AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets

Run Macro Based On Values In Column